git.iko.soy/Idris-dev
on bfa39bf help sign in
Idris-dev/src/IRTS/LParser.hs
276 lines 11 kB history raw
1module IRTS.LParser where
3import Idris.AbsSyntaxTree
4import Core.CoreParser
5import Core.TT
6import IRTS.Lang
7import IRTS.Simplified
8import IRTS.Bytecode
9import IRTS.CodegenCommon
10import IRTS.CodegenC
11import IRTS.CodegenJava
12import IRTS.CodegenJavaScript
13import IRTS.Defunctionalise
14import Paths_idris
16import Text.ParserCombinators.Parsec
17import Text.ParserCombinators.Parsec.Error
18import Text.ParserCombinators.Parsec.Expr
19import Text.ParserCombinators.Parsec.Language
20import qualified Text.ParserCombinators.Parsec.Token as PTok
22import Data.List
23import Control.Monad.State
24import Debug.Trace
25import Data.Maybe
26import System.FilePath
27import Idris.Error
29type TokenParser a = PTok.TokenParser a
31type LParser = GenParser Char ()
33lexer :: TokenParser ()
34lexer = idrisLexer
36whiteSpace= PTok.whiteSpace lexer
37lexeme = PTok.lexeme lexer
38symbol = PTok.symbol lexer
39natural = PTok.natural lexer
40parens = PTok.parens lexer
41semi = PTok.semi lexer
42comma = PTok.comma lexer
43identifier= PTok.identifier lexer
44reserved = PTok.reserved lexer
45operator = PTok.operator lexer
46reservedOp= PTok.reservedOp lexer
47integer = PTok.integer lexer
48float = PTok.float lexer
49strlit = PTok.stringLiteral lexer
50chlit = PTok.charLiteral lexer
51lchar = lexeme.char
53fovm :: Codegen -> OutputType -> FilePath -> IO ()
54fovm cgn outty f
55 = do defs <- parseFOVM f
56 let (nexttag, tagged) = addTags 0 (liftAll defs)
57 ctxtIn = addAlist tagged emptyContext
58 defuns = defunctionalise nexttag ctxtIn
59 putStrLn $ showSep "\n" (map show (toAlist defuns))
60 let checked = checkDefs defuns (toAlist defuns)
61-- print checked
62 case checked of
63 OK c -> case cgn of
64 ViaC -> codegenC c "a.out" outty ["math.h"] "" "" "" TRACE
65 ViaJava -> codegenJava [] c "a.out" [] [] outty
66 Error e -> fail (show e)
68parseFOVM :: FilePath -> IO [(Name, LDecl)]
69parseFOVM fname = do -- putStrLn $ "Reading " ++ fname
70 fp <- readFile fname
71 case runParser pProgram () fname fp of
72 Left err -> fail (show err)
73 Right x -> return x
75pProgram :: LParser [(Name, LDecl)]
76pProgram = do fs <- many1 pLDecl
77 eof
78 return fs
80pLDecl :: LParser (Name, LDecl)
81pLDecl = do reserved "data"
82 n <- iName []
83 ar <- natural
84 return (n, LConstructor n (-1) (fromInteger ar))
85 <|> do reserved "fun"
86 n <- iName []
87 lchar '('
88 args <- sepBy (iName []) (lchar ',')
89 lchar ')'
90 lchar '='
91 def <- pLExp
92 return (n, LFun [] n args def)
94pLExp = buildExpressionParser optable pLExp'
96optable = [[binary "*" (\x y -> LOp (LTimes (ATInt ITNative)) [x,y]) AssocLeft,
97 binary "/" (\x y -> LOp (LSDiv (ATInt ITNative)) [x,y]) AssocLeft,
98 binary "*." (\x y -> LOp (LTimes ATFloat) [x,y]) AssocLeft,
99 binary "/." (\x y -> LOp (LSDiv ATFloat) [x,y]) AssocLeft,
100 binary "*:" (\x y -> LOp (LTimes (ATInt ITBig)) [x,y]) AssocLeft,
101 binary "/:" (\x y -> LOp (LSDiv (ATInt ITBig)) [x,y]) AssocLeft,
102 binary "*," (\x y -> LOp (LTimes (ATInt ITChar)) [x, y]) AssocLeft,
103 binary "/," (\x y -> LOp (LSDiv (ATInt ITChar)) [x, y]) AssocLeft
104 ],
105 [
106 binary "+" (\x y -> LOp (LPlus (ATInt ITNative)) [x,y]) AssocLeft,
107 binary "-" (\x y -> LOp (LMinus (ATInt ITNative)) [x,y]) AssocLeft,
108 binary "++" (\x y -> LOp LStrConcat [x,y]) AssocLeft,
109 binary "+." (\x y -> LOp (LPlus ATFloat) [x,y]) AssocLeft,
110 binary "-." (\x y -> LOp (LMinus ATFloat) [x,y]) AssocLeft,
111 binary "+:" (\x y -> LOp (LPlus (ATInt ITBig)) [x,y]) AssocLeft,
112 binary "-:" (\x y -> LOp (LMinus (ATInt ITBig)) [x,y]) AssocLeft,
113 binary "+," (\x y -> LOp (LPlus (ATInt ITChar)) [x,y]) AssocLeft,
114 binary "-," (\x y -> LOp (LMinus (ATInt ITChar)) [x,y]) AssocLeft
115 ],
116 [
117 binary "==" (\x y -> LOp (LEq (ATInt ITNative)) [x, y]) AssocNone,
118 binary "==." (\x y -> LOp (LEq ATFloat) [x, y]) AssocNone,
119 binary "<" (\x y -> LOp (LSLt (ATInt ITNative)) [x, y]) AssocNone,
120 binary "<." (\x y -> LOp (LSLt ATFloat) [x, y]) AssocNone,
121 binary ">" (\x y -> LOp (LSGt (ATInt ITNative)) [x, y]) AssocNone,
122 binary ">." (\x y -> LOp (LSGt ATFloat) [x, y]) AssocNone,
123 binary "<=" (\x y -> LOp (LSLe (ATInt ITNative)) [x, y]) AssocNone,
124 binary "<=." (\x y -> LOp (LSLe ATFloat) [x, y]) AssocNone,
125 binary ">=" (\x y -> LOp (LSGe (ATInt ITNative)) [x, y]) AssocNone,
126 binary ">=." (\x y -> LOp (LSGe ATFloat) [x, y]) AssocNone,
128 binary "==:" (\x y -> LOp (LEq (ATInt ITBig)) [x, y]) AssocNone,
129 binary "<:" (\x y -> LOp (LSLt (ATInt ITBig)) [x, y]) AssocNone,
130 binary ">:" (\x y -> LOp (LSGt (ATInt ITBig)) [x, y]) AssocNone,
131 binary "<=:" (\x y -> LOp (LSLe (ATInt ITBig)) [x, y]) AssocNone,
132 binary ">=:" (\x y -> LOp (LSGe (ATInt ITBig)) [x, y]) AssocNone,
134 binary "==," (\x y -> LOp (LEq (ATInt ITChar)) [x, y]) AssocNone,
135 binary "<," (\x y -> LOp (LSLt (ATInt ITChar)) [x, y]) AssocNone,
136 binary ">," (\x y -> LOp (LSGt (ATInt ITChar)) [x, y]) AssocNone,
137 binary "<=," (\x y -> LOp (LSLe (ATInt ITChar)) [x, y]) AssocNone,
138 binary ">=," (\x y -> LOp (LSGe (ATInt ITChar)) [x, y]) AssocNone
139 ]]
141binary name f assoc = Infix (do reservedOp name; return f) assoc
143pLExp' :: LParser LExp
144pLExp' = try (do lchar '%'; pCast)
145 <|> try (do lchar '%'; pPrim)
146 <|> try (do tc <- option False (do lchar '%'; reserved "tc"; return True)
147 x <- iName [];
148 lazy <- option False (do lchar '@'; return True)
149 lchar '('
150 args <- sepBy pLExp (lchar ',')
151 lchar ')'
152 if null args
153 then if lazy then return (LLazyApp x [])
154 else return (LV (Glob x))
155 else if lazy then return (LLazyApp x args)
156 else return (LApp tc (LV (Glob x)) args))
157 <|> do lchar '('; e <- pLExp; lchar ')'; return e
158 <|> pLConst
159 <|> do reserved "let"; x <- iName []; lchar '='; v <- pLExp
160 reserved "in"; e <- pLExp
161 return (LLet x v e)
162 <|> do lchar '\\'; xs <- sepBy (iName []) (lchar ',')
163 symbol "=>"
164 e <- pLExp
165 return (LLam xs e)
166 <|> do reserved "foreign"; l <- pLang; t <- pType
167 fname <- strlit
168 lchar '('
169 fargs <- sepBy (do t' <- pType; e <- pLExp; return (t', e)) (lchar ',')
170 lchar ')'
171 return (LForeign l t fname fargs)
172 <|> pCase
173 <|> do x <- iName []
174 return (LV (Glob x))
176pLang = do reserved "C"; return LANG_C
178pType = do reserved "Int"; return (FArith (ATInt ITNative))
179 <|> do reserved "Char"; return (FArith (ATInt ITChar))
180 <|> do reserved "Float"; return (FArith ATFloat)
181 <|> do reserved "String"; return FString
182 <|> do reserved "Unit"; return FUnit
183 <|> do reserved "Ptr"; return FPtr
184 <|> do reserved "Any"; return FAny
186pCase :: LParser LExp
187pCase = do reserved "case"; e <- pLExp; reserved "of"
188 lchar '{'
189 alts <- sepBy1 pAlt (lchar '|')
190 lchar '}'
191 return (LCase e alts)
193pCast :: LParser LExp
194pCast = do reserved "FloatString"; lchar '('; e <- pLExp; lchar ')'
195 return (LOp LFloatStr [e])
196 <|> do reserved "StringFloat"; lchar '('; e <- pLExp; lchar ')'
197 return (LOp LStrFloat [e])
198 <|> do reserved "FloatInt"; lchar '('; e <- pLExp; lchar ')'
199 return (LOp (LFloatInt ITNative) [e])
200 <|> do reserved "IntFloat"; lchar '('; e <- pLExp; lchar ')'
201 return (LOp (LIntFloat ITNative) [e])
202 <|> do reserved "StringInt"; lchar '('; e <- pLExp; lchar ')'
203 return (LOp (LStrInt ITNative) [e])
204 <|> do reserved "IntString"; lchar '('; e <- pLExp; lchar ')'
205 return (LOp (LIntStr ITNative) [e])
206 <|> do reserved "BigInt"; lchar '('; e <- pLExp; lchar ')'
207 return (LOp (LTrunc ITBig ITNative) [e])
208 <|> do reserved "IntBig"; lchar '('; e <- pLExp; lchar ')'
209 return (LOp (LSExt ITNative ITBig) [e])
210 <|> do reserved "BigString"; lchar '('; e <- pLExp; lchar ')'
211 return (LOp (LIntStr ITBig) [e])
212 <|> do reserved "StringBig"; lchar '('; e <- pLExp; lchar ')'
213 return (LOp (LStrInt ITBig) [e])
215pPrim :: LParser LExp
216pPrim = do reserved "StrEq"; lchar '(';
217 e <- pLExp; lchar ',';
218 e' <- pLExp; lchar ')';
219 return (LOp LStrEq [e, e'])
220 <|> do reserved "StrLt"; lchar '('
221 e <- pLExp; lchar ','; e' <- pLExp;
222 lchar ')'
223 return (LOp LStrLt [e, e'])
224 <|> do reserved "StrLen"; lchar '('; e <- pLExp; lchar ')';
225 return (LOp LStrLen [e])
226 <|> do reserved "ReadString"; lchar '('; e <- pLExp; lchar ')';
227 return (LOp LReadStr [e])
228 <|> do reserved "WriteString"; lchar '(';
229 e <- pLExp; lchar ')'
230 return (LOp LPrintStr [e])
231 <|> do reserved "WriteInt"; lchar '(';
232 e <- pLExp; lchar ')';
233 return (LOp LPrintNum [e])
234 <|> do reserved "lazy"; lchar '(';
235 e <- pLExp; lchar ')';
236 return (LLazyExp e)
237 <|> do reserved "StrHead"; lchar '('; e <- pLExp; lchar ')';
238 return (LOp LStrHead [e])
239 <|> do reserved "StrTail"; lchar '('; e <- pLExp; lchar ')';
240 return (LOp LStrTail [e])
241 <|> do reserved "StrRev"; lchar '('; e <- pLExp; lchar ')';
242 return (LOp LStrRev [e])
243 <|> do reserved "StrCons"; lchar '('; x <- pLExp; lchar ',';
244 xs <- pLExp; lchar ')';
245 return (LOp LStrCons [x, xs])
246 <|> do reserved "StrIndex"; lchar '('; x <- pLExp; lchar ',';
247 i <- pLExp; lchar ')';
248 return (LOp LStrIndex [x, i])
250pAlt :: LParser LAlt
251pAlt = try (do x <- iName []
252 lchar '('; args <- sepBy1 (iName []) (lchar ','); lchar ')'
253 symbol "=>"
254 rhs <- pLExp
255 return (LConCase (-1) x args rhs))
256 <|> do x <- iName [];
257 symbol "=>"
258 rhs <- pLExp
259 return (LConCase (-1) x [] rhs)
260 <|> do c <- natural
261 symbol "=>"
262 rhs <- pLExp
263 return (LConstCase (I (fromInteger c)) rhs)
264 <|> do symbol "_"
265 symbol "=>"
266 rhs <- pLExp
267 return (LDefaultCase rhs)
270pLConst :: LParser LExp
271pLConst = try (do f <- float; return $ LConst (Fl f))
272 <|> try (do i <- natural; lchar ':'; return $ LConst (BI i))
273 <|> try (do i <- natural; return $ LConst (I (fromInteger i)))
274 <|> try (do s <- strlit; return $ LConst (Str s))
275 <|> try (do c <- chlit; return $ LConst (Ch c))