Commit 2ae11e4c authored by Job Cuppen's avatar Job Cuppen

monads work idk how

parent 6040c8b5
module ex1
import StdEnv, StdArray, Data.Maybe
import Data.Functor, Control.Applicative, Control.Monad
import qualified Data.Map as Map
:: Gram
= Lit String // the given string as a literal
| Idn // Identifier: a String starting with an isAlpha character (see StdChar)
| Int // integer denotation
| Seq [Gram] // sequence of grammar elements
| Alt [Gram] // choice between alternative grammar elements
| Def Name Gram Gram // assign the first grammar to the given name, yield second grammar
| Var Name // represents the grammar of this name
:: Name :== String
:: State =
{input :: [String]
,store :: Store
}
:: Store :== 'Map'.Map Name Gram
:: Parse a = P (State -> (Maybe a, State))
instance Functor Parse where
fmap f (P g) = P \s1.let (a, s2) = g s1 in (fmap f a, s2)
instance pure Parse where
pure a = P \s->(pure a, s)
instance <*> Parse where
(<*>) (P f) (P g)
= P \s1-> case f s1 of
(Just fa, s2) = case g s2 of
(Just ga, s3) = (Just (fa ga), s3)
(_, s3) = (Nothing, s3)
(_, s2) = (Nothing, s2)
instance Alternative Parse where
(<|>) (P a1) (P a2) = P (\s -> case a1 s of
(Just a, sP) -> (Just a, sP)
(Nothing, sP) -> case a2 s of
(Just a, sPP) -> (Just a, sPP)
(Nothing, sPP) -> (Nothing, sPP))
empty = P (\s -> (Nothing, s))
(?) infix 1 :: Bool (v a) -> (v a) | Alternative v
(?) b m = if b m empty
instance Monad Parse where
bind (P f) g
= P \s1 -> case f s1 of
(Just a, s2) -> unParse (g a) s2
(Nothing, s2) -> (Nothing, s2)
unParse :: (Parse a) -> (State -> (Maybe a, State))
unParse (P f) = f
next :: Parse String // yield the next input token and move it to seen
next = P \s -> case s.input of
[] = (Nothing, s)
_ = ((Just (hd s.input)), {s & input = tl s.input})
setGram :: Name Gram -> Parse Gram //use the given name to store the grammar
setGram n g = P \s->(pure g, {s & store = 'Map'.put n g s.store})
getGram :: Name -> Parse Gram // retrieve the grammar associated with this name
getGram n = P \s->('Map'.get n s.store, s)
:: TREE = LIT String | IDN String | INT Int | SEQ [TREE]
parse :: Gram -> Parse TREE
parse (Lit str) = next >>= \s-> (s == str) ? pure (LIT str)
parse Idn = next >>= \s-> (isAlpha s.[0]) ? pure (IDN s)
parse Int = next >>= \s-> and (map isDigit (fromString s)) ? pure (INT (toInt s))
parse (Seq []) = pure (SEQ [])
parse (Seq ls) = SEQ <$> sequence (map parse ls)
//parse (Seq ls) = fmap SEQ (sequence (map parse ls))
parse (Alt []) = empty
// parse (Alt [x:xs]) = parse x <|> parse xs
parse (Alt [x:xs]) = parse x <|> parse (Alt xs)
parse (Def n g1 g2) = setGram n g1 >>| parse g2
parse (Var n) = getGram n >>= parse
listIntGram :: Gram
listIntGram = Def "list" (
Alt [
Lit "[]"
, Seq[Lit "["
, Int
, Lit ":"
, Var "list"
, Lit "]"
]])
(Seq [Idn, Lit "=", Var "list"])
listArithGram :: Gram
listArithGram = Def "arithmetic" (
Alt [
Seq[
Int,
Alt [Lit "*", Lit "+", Lit "-"],
Var "arithmetic"
],
Int
]
)
(Var "arithmetic")
listIntInput = ["mylist", "=", "[", "7", ":", "[", "42", ":", "[]", "]", "]"]
arithInput = ["12", "*", "2", "+", "4", "*", "3", "*", "2", "-", "6"]
//Start = let (P f) = (parse listIntGram) in f {input = listIntInput, store = 'Map'.newMap}
Start = let (P f) = (parse listArithGram) in f {input = arithInput, store = 'Map'.newMap}
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment