git.iko.soy/Idris-dev
on 200475f help sign in
Idris-dev/src/IRTS/LParser.hs
264 lines 9.9 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 :: Target -> OutputType -> FilePath -> IO ()
53fovm tgt 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 tgt 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 [x,y]) AssocLeft,
96 binary "/" (\x y -> LOp LDiv [x,y]) AssocLeft,
97 binary "*." (\x y -> LOp LFTimes [x,y]) AssocLeft,
98 binary "/." (\x y -> LOp LFDiv [x,y]) AssocLeft,
99 binary "*:" (\x y -> LOp LBTimes [x,y]) AssocLeft,
100 binary "/:" (\x y -> LOp LBDiv [x,y]) AssocLeft
101 ],
102 [
103 binary "+" (\x y -> LOp LPlus [x,y]) AssocLeft,
104 binary "-" (\x y -> LOp LMinus [x,y]) AssocLeft,
105 binary "++" (\x y -> LOp LStrConcat [x,y]) AssocLeft,
106 binary "+." (\x y -> LOp LFPlus [x,y]) AssocLeft,
107 binary "-." (\x y -> LOp LFMinus [x,y]) AssocLeft,
108 binary "+:" (\x y -> LOp LBPlus [x,y]) AssocLeft,
109 binary "-:" (\x y -> LOp LBMinus [x,y]) AssocLeft
110 ],
111 [
112 binary "==" (\x y -> LOp LEq [x, y]) AssocNone,
113 binary "==." (\x y -> LOp LFEq [x, y]) AssocNone,
114 binary "<" (\x y -> LOp LLt [x, y]) AssocNone,
115 binary "<." (\x y -> LOp LFLt [x, y]) AssocNone,
116 binary ">" (\x y -> LOp LGt [x, y]) AssocNone,
117 binary ">." (\x y -> LOp LFGt [x, y]) AssocNone,
118 binary "<=" (\x y -> LOp LLe [x, y]) AssocNone,
119 binary "<=." (\x y -> LOp LFLe [x, y]) AssocNone,
120 binary ">=" (\x y -> LOp LGe [x, y]) AssocNone,
121 binary ">=." (\x y -> LOp LFGe [x, y]) AssocNone,
123 binary "==:" (\x y -> LOp LBEq [x, y]) AssocNone,
124 binary "<:" (\x y -> LOp LBLt [x, y]) AssocNone,
125 binary ">:" (\x y -> LOp LBGt [x, y]) AssocNone,
126 binary "<=:" (\x y -> LOp LBLe [x, y]) AssocNone,
127 binary ">=:" (\x y -> LOp LBGe [x, y]) AssocNone
128 ]]
130binary name f assoc = Infix (do reservedOp name; return f) assoc
132pLExp' :: LParser LExp
133pLExp' = try (do lchar '%'; pCast)
134 <|> try (do lchar '%'; pPrim)
135 <|> try (do tc <- option False (do lchar '%'; reserved "tc"; return True)
136 x <- iName [];
137 lazy <- option False (do lchar '@'; return True)
138 lchar '('
139 args <- sepBy pLExp (lchar ',')
140 lchar ')'
141 if null args
142 then if lazy then return (LLazyApp x [])
143 else return (LV (Glob x))
144 else if lazy then return (LLazyApp x args)
145 else return (LApp tc (LV (Glob x)) args))
146 <|> do lchar '('; e <- pLExp; lchar ')'; return e
147 <|> pLConst
148 <|> do reserved "let"; x <- iName []; lchar '='; v <- pLExp
149 reserved "in"; e <- pLExp
150 return (LLet x v e)
151 <|> do lchar '\\'; xs <- sepBy (iName []) (lchar ',')
152 symbol "=>"
153 e <- pLExp
154 return (LLam xs e)
155 <|> do reserved "foreign"; l <- pLang; t <- pType
156 fname <- strlit
157 lchar '('
158 fargs <- sepBy (do t' <- pType; e <- pLExp; return (t', e)) (lchar ',')
159 lchar ')'
160 return (LForeign l t fname fargs)
161 <|> pCase
162 <|> do x <- iName []
163 return (LV (Glob x))
165pLang = do reserved "C"; return LANG_C
167pType = do reserved "Int"; return FInt
168 <|> do reserved "Float"; return FDouble
169 <|> do reserved "String"; return FString
170 <|> do reserved "Unit"; return FUnit
171 <|> do reserved "Ptr"; return FPtr
172 <|> do reserved "Any"; return FAny
174pCase :: LParser LExp
175pCase = do reserved "case"; e <- pLExp; reserved "of"
176 lchar '{'
177 alts <- sepBy1 pAlt (lchar '|')
178 lchar '}'
179 return (LCase e alts)
181pCast :: LParser LExp
182pCast = do reserved "FloatString"; lchar '('; e <- pLExp; lchar ')'
183 return (LOp LFloatStr [e])
184 <|> do reserved "StringFloat"; lchar '('; e <- pLExp; lchar ')'
185 return (LOp LStrFloat [e])
186 <|> do reserved "FloatInt"; lchar '('; e <- pLExp; lchar ')'
187 return (LOp LFloatInt [e])
188 <|> do reserved "IntFloat"; lchar '('; e <- pLExp; lchar ')'
189 return (LOp LIntFloat [e])
190 <|> do reserved "StringInt"; lchar '('; e <- pLExp; lchar ')'
191 return (LOp LStrInt [e])
192 <|> do reserved "IntString"; lchar '('; e <- pLExp; lchar ')'
193 return (LOp LIntStr [e])
194 <|> do reserved "BigInt"; lchar '('; e <- pLExp; lchar ')'
195 return (LOp LBigInt [e])
196 <|> do reserved "IntBig"; lchar '('; e <- pLExp; lchar ')'
197 return (LOp LIntBig [e])
198 <|> do reserved "BigString"; lchar '('; e <- pLExp; lchar ')'
199 return (LOp LBigStr [e])
200 <|> do reserved "StringBig"; lchar '('; e <- pLExp; lchar ')'
201 return (LOp LStrBig [e])
203pPrim :: LParser LExp
204pPrim = do reserved "StrEq"; lchar '(';
205 e <- pLExp; lchar ',';
206 e' <- pLExp; lchar ')';
207 return (LOp LStrEq [e, e'])
208 <|> do reserved "StrLt"; lchar '('
209 e <- pLExp; lchar ','; e' <- pLExp;
210 lchar ')'
211 return (LOp LStrLt [e, e'])
212 <|> do reserved "StrLen"; lchar '('; e <- pLExp; lchar ')';
213 return (LOp LStrLen [e])
214 <|> do reserved "ReadString"; lchar '('; e <- pLExp; lchar ')';
215 return (LOp LReadStr [e])
216 <|> do reserved "WriteString"; lchar '(';
217 e <- pLExp; lchar ')'
218 return (LOp LPrintStr [e])
219 <|> do reserved "WriteInt"; lchar '(';
220 e <- pLExp; lchar ')';
221 return (LOp LPrintNum [e])
222 <|> do reserved "lazy"; lchar '(';
223 e <- pLExp; lchar ')';
224 return (LLazyExp e)
225 <|> do reserved "StrHead"; lchar '('; e <- pLExp; lchar ')';
226 return (LOp LStrHead [e])
227 <|> do reserved "StrTail"; lchar '('; e <- pLExp; lchar ')';
228 return (LOp LStrTail [e])
229 <|> do reserved "StrRev"; lchar '('; e <- pLExp; lchar ')';
230 return (LOp LStrRev [e])
231 <|> do reserved "StrCons"; lchar '('; x <- pLExp; lchar ',';
232 xs <- pLExp; lchar ')';
233 return (LOp LStrCons [x, xs])
234 <|> do reserved "StrIndex"; lchar '('; x <- pLExp; lchar ',';
235 i <- pLExp; lchar ')';
236 return (LOp LStrIndex [x, i])
238pAlt :: LParser LAlt
239pAlt = try (do x <- iName []
240 lchar '('; args <- sepBy1 (iName []) (lchar ','); lchar ')'
241 symbol "=>"
242 rhs <- pLExp
243 return (LConCase (-1) x args rhs))
244 <|> do x <- iName [];
245 symbol "=>"
246 rhs <- pLExp
247 return (LConCase (-1) x [] rhs)
248 <|> do c <- natural
249 symbol "=>"
250 rhs <- pLExp
251 return (LConstCase (I (fromInteger c)) rhs)
252 <|> do symbol "_"
253 symbol "=>"
254 rhs <- pLExp
255 return (LDefaultCase rhs)
258pLConst :: LParser LExp
259pLConst = try (do f <- float; return $ LConst (Fl f))
260 <|> try (do i <- natural; lchar ':'; return $ LConst (BI i))
261 <|> try (do i <- natural; return $ LConst (I (fromInteger i)))
262 <|> try (do s <- strlit; return $ LConst (Str s))
263 <|> try (do c <- chlit; return $ LConst (Ch c))