afp/a7/a7.icl

   1 module a7
   2
   3 import StdEnv
   4
   5 import qualified Data.Map as Map
   6
   7 import Data.Func
   8 import Data.Functor
   9 import Data.Maybe
  10 import Data.Tuple
  11 import Control.Applicative
  12 import Control.Monad
  13
  14 :: Gram
  15         = Lit String
  16         | Idn
  17         | Int
  18         | Seq [Gram]
  19         | Alt [Gram]
  20         | Def Name Gram Gram
  21         | Var Name
  22 :: Name :== String
  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]
  27
  28 runParse :: (Parse a) -> (State -> (Maybe a, State))
  29 runParse (Parse a) = a
  30
  31 instance Functor Parse where fmap f a = Parse (appFst (fmap f) <$> runParse a)
  32 instance Applicative Parse
  33 where
  34         pure a = Parse (tuple (pure a))
  35         <*> fab fb = Parse \s->let
  36                    (mab, (mb, s`)) = appSnd (runParse fb) (runParse fab s)
  37                 in (mab <*> mb, s`)
  38 instance Monad Parse
  39 where
  40         bind ma a2mb = Parse \s->case runParse ma s of
  41                 (Just a, s`) = runParse (a2mb a) s`
  42                 (Nothing, s`) = (Nothing, s`)
  43
  44 instance Alternative Parse
  45 where
  46         empty = Parse (tuple Nothing)
  47         <|> ma mb = Parse \s->case runParse ma s of
  48                 (Nothing, _) = runParse mb s
  49                 t = t
  50
  51 next :: Parse String
  52 next = Parse \s->case s.input of
  53         [] = (Nothing, s)
  54         [i:is] = (Just i, {s & input=is})
  55
  56 setGram :: Name Gram -> Parse Gram
  57 setGram n g = Parse \s->(Just g, {s & store='Map'.put n g s.store})
  58
  59 getGram :: Name -> Parse Gram
  60 getGram n = Parse \s->('Map'.get n s.store, s)
  61
  62 (?) infix 5 :: (a -> Bool) (Parse a) -> Parse a
  63 (?) p pa = pa >>= \a->if (p a) (pure a) empty
  64
  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
  73 parse _ = empty
  74
  75 run :: Gram [String] -> Maybe TREE
  76 run g t = fst (runParse (parse g) {store='Map'.newMap,input=t})
  77
  78 Start = (evalList <$> run listIntGram listIntInput, evalArith <$> run arithGram arithInput)
  79 where
  80         listIntInput = ["mylist","=","[","7",":","[","42",":","[]","]","]"]
  81         arithInput = ["12","*","2","+","4","*","3","*","2","-","6"]
  82
  83 listIntGram :: Gram
  84 listIntGram
  85         = Def "list" (Alt [Lit "[]",Seq [Lit "[",Int,Lit ":",Var "list",Lit "]"]])
  86         $ Seq [Idn,Lit "=",Var "list"]
  87
  88 arithGram :: Gram
  89 arithGram
  90         = Def "fac" (Alt [Seq [Int, Lit "*", Var "fac"], Int])
  91         $ Def "exp" (Alt [Seq [Var "fac", Lit "+", Var "exp"], Var "fac"])
  92         $ Var "exp"
  93
  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
  98 evalList _ = Nothing
  99
 100 evalArith :: TREE -> Maybe Int
 101 evalArith (INT i) = Just i
 102 evalArith (SEQ [a, LIT op, b]) = toOp op <*> evalArith a <*> evalArith b
 103 where
 104         toOp :: String -> Maybe (Int Int -> Int)
 105         toOp "+" = Just (+)
 106         toOp "*" = Just (*)
 107         toOp _ = Nothing
 108 evalArith _ = Nothing