@@ -0,0 +1,134 @@
1+module IRTS.LParser where
2+
3+import Core.CoreParser
4+import Core.TT
5+import IRTS.Lang
6+
7+import Text.ParserCombinators.Parsec
8+import Text.ParserCombinators.Parsec.Error
9+import Text.ParserCombinators.Parsec.Expr
10+import Text.ParserCombinators.Parsec.Language
11+import qualified Text.ParserCombinators.Parsec.Token as PTok
12+
13+import Data.List
14+import Control.Monad.State
15+import Debug.Trace
16+import Data.Maybe
17+import System.FilePath
18+
19+type TokenParser a = PTok.TokenParser a
20+
21+type LParser = GenParser Char ()
22+
23+lexer :: TokenParser ()
24+lexer = PTok.makeTokenParser idrisDef
25+
26+whiteSpace= PTok.whiteSpace lexer
27+lexeme = PTok.lexeme lexer
28+symbol = PTok.symbol lexer
29+natural = PTok.natural lexer
30+parens = PTok.parens lexer
31+semi = PTok.semi lexer
32+comma = PTok.comma lexer
33+identifier= PTok.identifier lexer
34+reserved = PTok.reserved lexer
35+operator = PTok.operator lexer
36+reservedOp= PTok.reservedOp lexer
37+integer = PTok.integer lexer
38+float = PTok.float lexer
39+strlit = PTok.stringLiteral lexer
40+chlit = PTok.charLiteral lexer
41+lchar = lexeme.char
42+
43+fovm :: FilePath -> IO ()
44+fovm f = do defs <- parseFOVM f
45+ print $ toAlist defs
46+
47+parseFOVM :: FilePath -> IO LDefs
48+parseFOVM fname = do putStrLn $ "Reading " ++ fname
49+ fp <- readFile fname
50+ case runParser pProgram () fname fp of
51+ Left err-> fail (show err)
52+ Right x -> return x
53+
54+pProgram :: LParser LDefs
55+pProgram = do fs <- many1 pLDecl
56+ eof
57+ return $ addAlist fs emptyContext
58+
59+pLDecl :: LParser (Name, LDecl)
60+pLDecl = do reserved "data"
61+ n <- iName []
62+ ar <- natural
63+ return (n, LConstructor n (fromInteger ar))
64+ <|> do reserved "fun"
65+ n <- iName []
66+ lchar '('
67+ args <- sepBy (iName []) (lchar ',')
68+ lchar ')'
69+ lchar '='
70+ def <- pLExp
71+ return (n, LFun n args def)
72+
73+pLExp = buildExpressionParser optable pLExp'
74+
75+optable = [[binary "*" (\x y -> LOp LTimes [x,y]) AssocLeft,
76+ binary "/" (\x y -> LOp LDiv [x,y]) AssocLeft],
77+ [binary "+" (\x y -> LOp LPlus [x,y]) AssocLeft,
78+ binary "-" (\x y -> LOp LMinus [x,y]) AssocLeft],
79+ [binary "==" (\x y -> LOp LEq [x, y]) AssocNone]]
80+
81+binary name f assoc = Infix (do reservedOp name; return f) assoc
82+
83+pLExp' :: LParser LExp
84+pLExp' = try (do x <- iName [];
85+ lchar '('
86+ args <- sepBy pLExp (lchar ',')
87+ lchar ')'
88+ if null args then return (LV (Glob x)) else return (LApp x args))
89+ <|> do lchar '('; e <- pLExp; lchar ')'; return e
90+ <|> pLConst
91+ <|> do reserved "let"; x <- iName []; lchar '='; v <- pLExp
92+ reserved "in"; e <- pLExp
93+ return (LLet (Glob x) v e)
94+ <|> pCase
95+ <|> do reserved "printNum"; e <- pLExp
96+ return (LOp LPrintNum [e])
97+ <|> do reserved "print"; e <- pLExp
98+ return (LOp LPrintStr [e])
99+ <|> do x <- iName []
100+ return (LV (Glob x))
101+
102+pCase :: LParser LExp
103+pCase = do reserved "case"; e <- pLExp; reserved "of"
104+ lchar '{'
105+ alts <- sepBy1 pAlt (lchar '|')
106+ lchar '}'
107+ return (LCase e alts)
108+
109+pAlt :: LParser LAlt
110+pAlt = try (do x <- iName []
111+ lchar '('; args <- sepBy1 (iName []) (lchar ','); lchar ')'
112+ symbol "=>"
113+ rhs <- pLExp
114+ return (LConCase (-1) x args rhs))
115+ <|> do x <- iName [];
116+ symbol "=>"
117+ rhs <- pLExp
118+ return (LConCase (-1) x [] rhs)
119+ <|> do c <- natural
120+ symbol "=>"
121+ rhs <- pLExp
122+ return (LConstCase (I (fromInteger c)) rhs)
123+ <|> do symbol "_"
124+ symbol "=>"
125+ rhs <- pLExp
126+ return (LDefaultCase rhs)
127+
128+
129+pLConst :: LParser LExp
130+pLConst = try (do f <- float; return $ LConst (Fl f))
131+ <|> try (do i <- natural; return $ LConst (I (fromInteger i)))
132+ <|> try (do s <- strlit; return $ LConst (Str s))
133+ <|> try (do c <- chlit; return $ LConst (Ch c))
134+