module Language.ML.Syntax
(
Id
, Expr (..)
, Decl
, Program (..)
, parseExpr
, parseExpr'
, parseProgram
, parseProgram'
, prettyExpr
, prettyDecl
, prettyProgram
) where
import Control.Monad
import Text.ParserCombinators.Parsec as P
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Token hiding (parens)
import Text.PrettyPrint hiding (parens)
import qualified Text.PrettyPrint as PP
import Applicative
type Id = String
data Expr
= Var Id
| Lam Id Expr
| App Expr Expr
| Let Id Expr Expr
| Fix Id Expr
deriving Eq
type Decl = (Id, Expr)
data Program = Program [Decl] Expr
deriving Eq
mlDef :: LanguageDef ()
mlDef = LanguageDef
{ commentStart = "/*"
, commentEnd = "*/"
, commentLine = "//"
, nestedComments = True
, identStart = letter
, identLetter = alphaNum <|> P.char '_'
, opStart = mzero
, opLetter = mzero
, reservedNames = ["let", "fix", "in"]
, reservedOpNames = ["\\", "="]
, caseSensitive = True
}
lexer = P.makeTokenParser mlDef
lid = P.identifier lexer
llet = P.reserved lexer "let"
lfix = P.reserved lexer "fix"
lin = P.reserved lexer "in"
llam = P.reservedOp lexer "\\"
ldot = P.dot lexer
lequal = P.reservedOp lexer "="
lsemi = P.semi lexer
parens = P.parens lexer
pvar = Var <$> lid
plam = flip (foldr Lam) <$> (llam *> many1 lid) <*> (ldot *> pexpr)
plet = Let <$> (llet *> lid) <*> (lequal *> pexpr) <*> (lin *> pexpr)
pfix = Fix <$> (lfix *> lid) <*> (ldot *> pexpr)
pexpr = plam <|> (foldl App <$> p <*> many p)
where p = parens (plam <|> pexpr) <|> try plet <|> try pfix <|> pvar
<?> "expression"
pdecl = (,) <$> lid <*> (lequal *> pexpr <* lsemi)
pprogram = Program <$> many (try pdecl) <*> (pexpr <* lsemi)
parseExpr :: String -> Either ParseError Expr
parseExpr = parse (spaces *> pexpr <* eof) ""
parseExpr' :: FilePath -> IO (Either ParseError Expr)
parseExpr' fn = parse (spaces *> pexpr <* eof) fn <$> readFile fn
parseProgram :: String -> Either ParseError Program
parseProgram = parse (spaces *> pprogram <* eof) ""
parseProgram' :: FilePath -> IO (Either ParseError Program)
parseProgram' fn = parse (spaces *> pprogram <* eof) fn <$> readFile fn
readParse :: Parser a -> String -> [(a, String)]
readParse p = either (const []) (: []) . parse p' ""
where p' = do x <- p
State {stateInput = input} <- getParserState
return (x, input)
instance Read Expr where
readsPrec _ = readParse pexpr
instance Read Program where
readsPrec _ = readParse pprogram
ppdot = text "."
pplam (Lam i e) = text i <+> pplam e
pplam e = ppdot <+> ppexpr e
ppappR e@(Var _) = ppexpr e
ppappR e = PP.parens (ppexpr e)
ppapp l@(Var _) r = ppexpr l <+> ppappR r
ppapp (App l m) r = ppapp l m <+> ppappR r
ppapp l r = PP.parens (ppexpr l) <+> ppappR r
ppexpr (Var i) = text i
ppexpr e@(Lam _ _) = text "\\" <> pplam e
ppexpr (App l r) = ppapp l r
ppexpr (Let i e1 e2) = (text "let" <+> text i <+> equals <+> ppexpr e1) $$
(text "in" <+> ppexpr e2)
ppexpr (Fix i e) = text "fix" <+> text i <> ppdot <+> ppexpr e
ppdecl (i, e) = text i <+> equals <+> ppexpr e <> PP.semi
ppprogram (Program es e) = vcat $ map ppdecl es ++ [ppexpr e <> PP.semi]
prettyExpr :: Expr -> Doc
prettyExpr = ppexpr
prettyDecl :: Decl -> Doc
prettyDecl = ppdecl
prettyProgram :: Program -> Doc
prettyProgram = ppprogram
instance Show Expr where
show = render . ppexpr
instance Show Program where
show = render . ppprogram