幾天前，我的一個朋友給了我一個Haskell問題

Hey, MK，假設我有個BNF，並且我在Haskell中有個這個BNF的parser。
現在，我想給這個BNF改一行，有沒有辦法不用動這個BNF parser的程式碼（因為是其他人寫的），而是對這parser進行擴充套件呢？

這問題挺有趣的，也不算難。

這問題說是extensibility problem，其實有兩個地方需要擴充套件。

0：Parser需要用open recursion之類的方法擴充套件

1：Parse出來的ADT也需要可擴充套件性

後半個需求見多了，Final Tagless，DTALC，Tree that grow，Recursion scheme style fix。。。於是放下不表，我們來處理前一個。

前半個。。Haskell's Overlooked Object System就搞過，當然他們有點heavy weight，打算隨手弄一個超級輕量級的：5行就夠了，多一行是小莎莎。

Ready？

1 data Object x = MkObject (x -> x)

1。Inheritance is not subtyping式的Object=recursive type。為了簡易性（反正也不需要多高的擴充套件性）就不model真。recursive type，而只有recursive dependency。

1 use :: Object x -> x
 
2 use (MkObject x) = let res = x res in res

2。3。最典型的tying the knot。其實就是fix了。

我們想想，這個x是什麼variant的呢？covariant還是contravariant？

1 inherit :: (a -> b) -> (b -> a) -> Object a -> Object b
2 inherit ab ba (MkObject aa) = MkObject (ab . aa . ba)

既然是invariant，那fmap contramap都用不上，但invariant依然能有map：兩邊一起傳進來就行了。4。5。

這就是一個prototype based oo system了。

接下來講怎麼用哈：

1 test :: Object (Int, Int)
2 test = MkObject $ \self -> (2, fst self + fst self)

這弄了個兩個field的object，第零個field初始值為2（可能因為繼承被override），第一個field為第零個field的值*2（不一定是3，如果任何field被override這個值都能改）。use test應該是(2, 4)。

1 inheritTest :: Object ((Int, Int), Int)
2 inheritTest = inherit (\(l, r) -> ((l + 1, r + 2), r + 1)) fst test

這裡繼承了上面的Object，override了l(l + 1是super + 1），r被override到super + 2，加了個新的field，值是r+1。use inheritTest應該是((3, 8), 7)。記著傳進來的引數不是self而是super就很好理解了。

好，open recursion搞好了，剩下的就是標準的final tagless了，體力活，沒啥意思

 1 class AST repr where
 2   lit :: Int -> repr
 3   plus :: repr -> repr -> repr
 4 
 5 class Var repr where
 6   var :: String -> repr
 7 
 8 type WholeParser repr = Parser repr
 9 type LitParser repr = Parser repr
10 type PlusParser repr = Parser repr
11 
12 intP :: Parser Int
13 intP = read <$> many1 digit
14 
15 stringP :: Parser String
16 stringP = many1 letter
17 
18 type OriginalParser repr = ((LitParser repr, PlusParser repr), WholeParser repr)
19 originalParser :: AST repr => Object (OriginalParser repr)
20 originalParser = MkObject $ \(~(_, p)) -> let
21   litP = lit <$> intP
22   plusP = between (char '(') (char ')') (do {l <- p; spaces; char '+'; spaces; r <- p; return $ plus l r})
23   wholeP = litP <|> plusP in
24   ((litP, plusP), wholeP)
25 
26 type VarParser repr = Parser repr
27 extendedParser :: (AST repr, Var repr) => Object (VarParser repr, OriginalParser repr)
28 extendedParser = inherit extend snd originalParser
29   where
30     extend ~((litP, plusP), wholeP) = let
31       varP = var <$> stringP in
32       (varP, ((litP, plusP), varP <|> wholeP))
33 
34 instance AST String where
35   lit = show
36   plus x y = "(" ++ x ++ " " ++ "+" ++ " " ++ y ++ ")"
37 
38 instance Var String where
39   var x = x

大功告成。

程式碼在https://github.com/MarisaKirisame/extensible-parser/blob/master/src/Lib.hs

Q：封裝呢？

A：Abstract Type is Existential Type

Q：這是prototype based的，class怎麼辦？

A：A Theory Of Object裡面講過怎麼用prototype來做class

Q：多繼承呢？

A：給定Object a，Object b，可以組合出Object (a, b)，要菱形繼承自己手動再inherit一下就好

Q：Subtyping?

A：Typeclass。

如果大家感興趣，請評論下，我可以再寫個blog把這些功能補完。