5 import qualified Data.Map as Map
11 import Control.Applicative
23 :: State = {input :: [String], store :: Store}
24 :: Store :== 'Map'.Map Name Gram
25 :: Parse a = Parse (State -> (Maybe a, State))
26 :: TREE = LIT String | IDN String | INT Int | SEQ [TREE]
28 runParse :: (Parse a) -> (State -> (Maybe a, State))
29 runParse (Parse a) = a
31 instance Functor Parse where fmap f a = Parse (appFst (fmap f) <$> runParse a)
32 instance Applicative Parse
34 pure a = Parse (tuple (pure a))
35 <*> fab fb = Parse \s->let
36 (mab, (mb, s`)) = appSnd (runParse fb) (runParse fab s)
40 bind ma a2mb = Parse \s->case runParse ma s of
41 (Just a, s`) = runParse (a2mb a) s`
42 (Nothing, s`) = (Nothing, s`)
44 instance Alternative Parse
46 empty = Parse (tuple Nothing)
47 <|> ma mb = Parse \s->case runParse ma s of
48 (Nothing, _) = runParse mb s
52 next = Parse \s->case s.input of
54 [i:is] = (Just i, {s & input=is})
56 setGram :: Name Gram -> Parse Gram
57 setGram n g = Parse \s->(Just g, {s & store='Map'.put n g s.store})
59 getGram :: Name -> Parse Gram
60 getGram n = Parse \s->('Map'.get n s.store, s)
62 (?) infix 5 :: (a -> Bool) (Parse a) -> Parse a
63 (?) p pa = pa >>= \a->if (p a) (pure a) empty
65 parse :: Gram -> Parse TREE
66 parse (Lit s) = LIT <$> ((==)s) ? next
67 parse Idn = IDN <$> (\s->isAlpha s.[0]) ? next
68 parse Int = INT o toInt <$> (\s->toString (toInt s) == s) ? next
69 parse (Seq gs) = SEQ <$> sequence (map parse gs)
70 parse (Alt as) = foldr (<|>) empty (map parse as)
71 parse (Def n g1 g2) = setGram n g1 *> parse g2
72 parse (Var n) = getGram n >>= parse
75 run :: Gram [String] -> Maybe TREE
76 run g t = fst (runParse (parse g) {store='Map'.newMap,input=t})
78 Start = (evalList <$> run listIntGram listIntInput, evalArith <$> run arithGram arithInput)
80 listIntInput = ["mylist","=","[","7",":","[","42",":","[]","]","]"]
81 arithInput = ["12","*","2","+","4","*","3","*","2","-","6"]
85 = Def "list" (Alt [Lit "[]",Seq [Lit "[",Int,Lit ":",Var "list",Lit "]"]])
86 $ Seq [Idn,Lit "=",Var "list"]
90 = Def "fac" (Alt [Seq [Int, Lit "*", Var "fac"], Int])
91 $ Def "exp" (Alt [Seq [Var "fac", Lit "+", Var "exp"], Var "fac"])
94 evalList :: TREE -> Maybe [Int]
95 evalList (LIT "[]") = Just []
96 evalList (SEQ [LIT "[", INT i, LIT ":", r, LIT "]"]) = evalList r >>= \r->pure [i:r]
97 evalList (SEQ [IDN _, LIT "=", l]) = evalList l
100 evalArith :: TREE -> Maybe Int
101 evalArith (INT i) = Just i
102 evalArith (SEQ [a, LIT op, b]) = toOp op <*> evalArith a <*> evalArith b
104 toOp :: String -> Maybe (Int Int -> Int)
108 evalArith _ = Nothing