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