願你走出半生，歸來仍是Java Parser

幾天前，我的一個朋友給了我一個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？

data Object x = MkObject (x -> x)

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

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

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

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

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

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

這就是一個prototype based oo system了。

接下來講怎么用哈：

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

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

inheritTest :: Object ((Int, Int), Int)
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了，體力活，沒啥意思

class AST repr where
  lit :: Int -> repr
  plus :: repr -> repr -> repr

class Var repr where
  var :: String -> repr

type WholeParser repr = Parser repr
type LitParser repr = Parser repr
type PlusParser repr = Parser repr

intP :: Parser Int
intP = read <$> many1 digit

stringP :: Parser String
stringP = many1 letter

type OriginalParser repr = ((LitParser repr, PlusParser repr), WholeParser repr)
originalParser :: AST repr => Object (OriginalParser repr)
originalParser = MkObject $ \(~(_, p)) -> let
  litP = lit <$> intP
  plusP = between (char '(') (char ')') (do {l <- p; spaces; char '+'; spaces; r <- p; return $ plus l r})
  wholeP = litP <|> plusP in
  ((litP, plusP), wholeP)

type VarParser repr = Parser repr
extendedParser :: (AST repr, Var repr) => Object (VarParser repr, OriginalParser repr)
extendedParser = inherit extend snd originalParser
  where
    extend ~((litP, plusP), wholeP) = let
      varP = var <$> stringP in
      (varP, ((litP, plusP), varP <|> wholeP))

instance AST String where
  lit = show
  plus x y = "(" ++ x ++ " " ++ "+" ++ " " ++ y ++ ")"

instance Var String where
  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把這些功能補完。