+++ /dev/null
-module a7
-
-import StdEnv
-
-import qualified Data.Map as Map
-
-import Data.Func
-import Data.Functor
-import Data.Maybe
-import Data.Tuple
-import Control.Applicative
-import Control.Monad
-
-:: Gram
- = Lit String
- | Idn
- | Int
- | Seq [Gram]
- | Alt [Gram]
- | Def Name Gram Gram
- | Var Name
-:: Name :== String
-:: State = {input :: [String], store :: Store}
-:: Store :== 'Map'.Map Name Gram
-:: Parse a = Parse (State -> (Maybe a, State))
-:: TREE = LIT String | IDN String | INT Int | SEQ [TREE]
-
-runParse :: (Parse a) -> (State -> (Maybe a, State))
-runParse (Parse a) = a
-
-instance Functor Parse where fmap f a = Parse (appFst (fmap f) <$> runParse a)
-instance Applicative Parse
-where
- pure a = Parse (tuple (pure a))
- <*> fab fb = Parse \s->let
- (mab, (mb, s`)) = appSnd (runParse fb) (runParse fab s)
- in (mab <*> mb, s`)
-instance Monad Parse
-where
- bind ma a2mb = Parse \s->case runParse ma s of
- (Just a, s`) = runParse (a2mb a) s`
- (Nothing, s`) = (Nothing, s`)
-
-instance Alternative Parse
-where
- empty = Parse (tuple Nothing)
- <|> ma mb = Parse \s->case runParse ma s of
- (Nothing, _) = runParse mb s
- t = t
-
-next :: Parse String
-next = Parse \s->case s.input of
- [] = (Nothing, s)
- [i:is] = (Just i, {s & input=is})
-
-setGram :: Name Gram -> Parse Gram
-setGram n g = Parse \s->(Just g, {s & store='Map'.put n g s.store})
-
-getGram :: Name -> Parse Gram
-getGram n = Parse \s->('Map'.get n s.store, s)
-
-(?) infix 5 :: (a -> Bool) (Parse a) -> Parse a
-(?) p pa = pa >>= \a->if (p a) (pure a) empty
-
-parse :: Gram -> Parse TREE
-parse (Lit s) = LIT <$> ((==)s) ? next
-parse Idn = IDN <$> next
-parse Int = INT o toInt <$> (\s->toString (toInt s) == s) ? next
-parse (Seq gs) = SEQ <$> sequence (map parse gs)
-parse (Alt as) = foldr (<|>) empty (map parse as)
-parse (Def n g1 g2) = setGram n g1 *> parse g2
-parse (Var n) = join (parse <$> getGram n)
-parse _ = empty
-
-run :: Gram [String] -> Maybe TREE
-run g t = fst (runParse (parse g) {store='Map'.newMap,input=t})
-
-Start = (run listIntGram listIntInput, run arithGram arithInput)
-where
- listIntInput = ["mylist","=","[","7",":","[","42",":","[]","]","]"]
- arithInput = ["12","*","2","+","4","*","3","*","2","-","6"]
-
-listIntGram :: Gram
-listIntGram
- = Def "list" (Alt [Lit "[]",Seq [Lit "[",Int,Lit ":",Var "list",Lit "]"]])
- $ Seq [Idn,Lit "=",Var "list"]
-
-arithGram :: Gram
-arithGram
- = Def "fac" (Alt [Seq [Int, Lit "*", Var "fac"], Int])
- $ Def "exp" (Alt [Seq [Var "fac", Lit "+", Var "exp"], Var "fac"])
- $ Var "exp"