module Language.Noodle.Parsing.Noodle where
import Language.Noodle.Syntax
import Language.Noodle.Parsing.String
type NParser a = Parser () a
topDecls :: NParser Decls
topDecls = do ds <- sepBy1 decl $ reserved ";"
return $ Decls ds
decls :: NParser Decls
decls = oneDecls <|> block topDecls where
oneDecls = do d <- decl
return $ Decls [d]
decl :: NParser Decl
decl = intThunk <|> intFun <|> intOp <|> intMod <|>
fail "expected declaration" where
intThunk = do (n,c) <- clause ident comp
return $ IntThunk n c
intFun = do ((p,n),c) <- clause funHead comp
return $ IntFun p n c where
funHead = do p <- pattern
n <- ident <|> oper
return (p,n)
intOp = do ((p1,o,p2),c) <- clause opHead comp
return $ IntOp p1 o p2 c where
opHead = do p1 <- pattern
op <- oper
p2 <- pattern
return (p1,op,p2)
intMod = do reserved "module"
name <- ident
ds <- decls
return $ IntMod name ds
comp :: NParser Comp
comp = tryComp <|> withComp <|>
inComp <|> patMatch <|> exprComp
<|> fail "expected computation" where
withComp = do reserved "with"
mc <- comp
reserved ";"
rest <- comp
return $ With mc rest
inComp = do reserved "in"
c <- comp
reserved ";"
ds <- decls
return $ In ds c
patMatch = do p <- pattern
reserved "="
c1 <- comp
reserved ";"
c2 <- comp
return $ PatMatch p c1 c2
tryComp = do reserved "handler"
c1 <- comp
reserved ";"
c2 <- comp
return $ Handler c1 c2
exprComp = do e <- expr
return $ ExprComp e
clause :: NParser a -> NParser b -> NParser (a,b)
clause f s = do first <- f
reserved ":="
second <- s
return (first,second)
block :: NParser a -> NParser a
block p = do lBrace
r <- p
rBrace
return r
expr = exprOp
exprOp = do app <- exprApp
rest <- many subOp
case rest of
[] -> return app
_ -> return $ (foldl (\a f -> f a) app rest)
where
subOp = do o <- oper
a <- exprApp
return $ (\a1 -> ExprOp a1 o a)
exprApp = do l <- modRef
es <- many modRef
case es of
[] -> return l
_ -> return $ foldl ExprApp l es
modRef = do e <- exprLit
refs <- many subRef
case refs of
[] -> return e
_ -> return $ foldl ExprApp e refs
where
subRef = do reserved "."
n <- (ident <|> oper)
return (ModRef n)
exprLit = do l <- literal comp
return $ Lit l
pattern :: NParser Pattern
pattern = do l <- literal pattern
return $ Pat l
literal :: NParser a -> NParser (Literal a)
literal p = number <|> identifier <|> symbLit <|> stringLit <|> absLit p <|> prodLit p <|> paren p
identifier =
do i <- ident
return (Ident i)
number = do n <- numeric
return $ Numb (read n)
paren p =
do lParen
p' <- p
rParen
return $ Paren p'
isReserved :: String -> Bool
isReserved s = or $ map (==s)
[ ":="
, "=:"
, "="
, ";"
, "."
, "`"
, ","
, "("
, ")"
, "with"
, "in"
, "handler"
, "module" ]
reserved :: String -> NParser ()
reserved s = notcode >> string s >> return ()
lBrace :: NParser ()
lBrace = notcode >> char '{' >> return ()
rBrace :: NParser ()
rBrace = notcode >> char '}' >> return ()
lParen :: NParser ()
lParen = notcode >> char '(' >> return ()
rParen :: NParser ()
rParen = notcode >> char ')' >> return ()
ident :: NParser String
ident = do notcode
first <- alphaLower
rest <- many (char '_' <|> alphaUpper <|> alphaLower <|> digit)
let name = (first:rest)
if isReserved name
then fail $ "unexpected keyword: " ++ name
else return name
symbLit :: NParser (Literal a)
symbLit = do notcode
first <- alphaUpper
rest <- many (char '_' <|> alphaUpper <|> alphaLower <|> digit)
return $ Symb (first:rest)
prodLit :: NParser a -> NParser (Literal a)
prodLit p = do reserved "("
first <- p
second <- many1 (reserved "," >> p)
reserved ")"
return $ ProdLit first (head second) (tail second)
absLit p = do reserved "["
l <- p
reserved "]"
return $ Abs l
oper :: NParser String
oper = do notcode
op <- many1 opChar
if isReserved op
then fail $ "unexpected reserved operator: " ++ op
else return op
numeric :: NParser String
numeric = notcode >> many1 digit
opChar :: NParser Char
opChar = oneOf "!@#$%^&*-+=|\\/<>,:~"
opChars = many1 opChar
stringLit :: NParser (Literal a)
stringLit = do notcode
char '"'
val <- many strChar
char '"'
return $ StrLit val where
strChar
= do c <- satisfy (\_ -> True)
case c of
'\\' -> satisfy (\_ -> True)
'"' -> fail "unexpected quote"
_ -> return c
notcode :: NParser ()
notcode = do many (comment <|> (whiteChar >> return ""))
return ()
comment :: NParser String
comment = do char '`'
cs <- many (satisfy nottick)
char '`'
return cs where
nottick '`' = False
nottick _ = True