几天前，我的一个朋友给了我一个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把这些功能补完。