git.iko.soy/Idris-dev
on 496cf41 help sign in
Idris-dev/src/IRTS/LParser.hs
263 lines 9.8 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.Defunctionalise
13import Paths_idris
15import Text.ParserCombinators.Parsec
16import Text.ParserCombinators.Parsec.Error
17import Text.ParserCombinators.Parsec.Expr
18import Text.ParserCombinators.Parsec.Language
19import qualified Text.ParserCombinators.Parsec.Token as PTok
21import Data.List
22import Control.Monad.State
23import Debug.Trace
24import Data.Maybe
25import System.FilePath
27type TokenParser a = PTok.TokenParser a
29type LParser = GenParser Char ()
31lexer :: TokenParser ()
32lexer = idrisLexer
34whiteSpace= PTok.whiteSpace lexer
35lexeme = PTok.lexeme lexer
36symbol = PTok.symbol lexer
37natural = PTok.natural lexer
38parens = PTok.parens lexer
39semi = PTok.semi lexer
40comma = PTok.comma lexer
41identifier= PTok.identifier lexer
42reserved = PTok.reserved lexer
43operator = PTok.operator lexer
44reservedOp= PTok.reservedOp lexer
45integer = PTok.integer lexer
46float = PTok.float lexer
47strlit = PTok.stringLiteral lexer
48chlit = PTok.charLiteral lexer
49lchar = lexeme.char
51fovm :: Target -> OutputType -> FilePath -> IO ()
52fovm tgt outty f
53 = do defs <- parseFOVM f
54 let (nexttag, tagged) = addTags 0 (liftAll defs)
55 ctxtIn = addAlist tagged emptyContext
56 defuns = defunctionalise nexttag ctxtIn
57 putStrLn $ showSep "\n" (map show (toAlist defuns))
58 let checked = checkDefs defuns (toAlist defuns)
59-- print checked
60 case checked of
61 OK c -> case tgt of
62 ViaC -> codegenC c "a.out" outty ["math.h"] "" "" TRACE
63 ViaJava -> codegenJava c "a.out" outty
64 Error e -> fail $ show e
66parseFOVM :: FilePath -> IO [(Name, LDecl)]
67parseFOVM fname = do -- putStrLn $ "Reading " ++ fname
68 fp <- readFile fname
69 case runParser pProgram () fname fp of
70 Left err-> fail (show err)
71 Right x -> return x
73pProgram :: LParser [(Name, LDecl)]
74pProgram = do fs <- many1 pLDecl
75 eof
76 return fs
78pLDecl :: LParser (Name, LDecl)
79pLDecl = do reserved "data"
80 n <- iName []
81 ar <- natural
82 return (n, LConstructor n (-1) (fromInteger ar))
83 <|> do reserved "fun"
84 n <- iName []
85 lchar '('
86 args <- sepBy (iName []) (lchar ',')
87 lchar ')'
88 lchar '='
89 def <- pLExp
90 return (n, LFun [] n args def)
92pLExp = buildExpressionParser optable pLExp'
94optable = [[binary "*" (\x y -> LOp LTimes [x,y]) AssocLeft,
95 binary "/" (\x y -> LOp LDiv [x,y]) AssocLeft,
96 binary "*." (\x y -> LOp LFTimes [x,y]) AssocLeft,
97 binary "/." (\x y -> LOp LFDiv [x,y]) AssocLeft,
98 binary "*:" (\x y -> LOp LBTimes [x,y]) AssocLeft,
99 binary "/:" (\x y -> LOp LBDiv [x,y]) AssocLeft
100 ],
101 [
102 binary "+" (\x y -> LOp LPlus [x,y]) AssocLeft,
103 binary "-" (\x y -> LOp LMinus [x,y]) AssocLeft,
104 binary "++" (\x y -> LOp LStrConcat [x,y]) AssocLeft,
105 binary "+." (\x y -> LOp LFPlus [x,y]) AssocLeft,
106 binary "-." (\x y -> LOp LFMinus [x,y]) AssocLeft,
107 binary "+:" (\x y -> LOp LBPlus [x,y]) AssocLeft,
108 binary "-:" (\x y -> LOp LBMinus [x,y]) AssocLeft
109 ],
110 [
111 binary "==" (\x y -> LOp LEq [x, y]) AssocNone,
112 binary "==." (\x y -> LOp LFEq [x, y]) AssocNone,
113 binary "<" (\x y -> LOp LLt [x, y]) AssocNone,
114 binary "<." (\x y -> LOp LFLt [x, y]) AssocNone,
115 binary ">" (\x y -> LOp LGt [x, y]) AssocNone,
116 binary ">." (\x y -> LOp LFGt [x, y]) AssocNone,
117 binary "<=" (\x y -> LOp LLe [x, y]) AssocNone,
118 binary "<=." (\x y -> LOp LFLe [x, y]) AssocNone,
119 binary ">=" (\x y -> LOp LGe [x, y]) AssocNone,
120 binary ">=." (\x y -> LOp LFGe [x, y]) AssocNone,
122 binary "==:" (\x y -> LOp LBEq [x, y]) AssocNone,
123 binary "<:" (\x y -> LOp LBLt [x, y]) AssocNone,
124 binary ">:" (\x y -> LOp LBGt [x, y]) AssocNone,
125 binary "<=:" (\x y -> LOp LBLe [x, y]) AssocNone,
126 binary ">=:" (\x y -> LOp LBGe [x, y]) AssocNone
127 ]]
129binary name f assoc = Infix (do reservedOp name; return f) assoc
131pLExp' :: LParser LExp
132pLExp' = try (do lchar '%'; pCast)
133 <|> try (do lchar '%'; pPrim)
134 <|> try (do tc <- option False (do lchar '%'; reserved "tc"; return True)
135 x <- iName [];
136 lazy <- option False (do lchar '@'; return True)
137 lchar '('
138 args <- sepBy pLExp (lchar ',')
139 lchar ')'
140 if null args
141 then if lazy then return (LLazyApp x [])
142 else return (LV (Glob x))
143 else if lazy then return (LLazyApp x args)
144 else return (LApp tc (LV (Glob x)) args))
145 <|> do lchar '('; e <- pLExp; lchar ')'; return e
146 <|> pLConst
147 <|> do reserved "let"; x <- iName []; lchar '='; v <- pLExp
148 reserved "in"; e <- pLExp
149 return (LLet x v e)
150 <|> do lchar '\\'; xs <- sepBy (iName []) (lchar ',')
151 symbol "=>"
152 e <- pLExp
153 return (LLam xs e)
154 <|> do reserved "foreign"; l <- pLang; t <- pType
155 fname <- strlit
156 lchar '('
157 fargs <- sepBy (do t' <- pType; e <- pLExp; return (t', e)) (lchar ',')
158 lchar ')'
159 return (LForeign l t fname fargs)
160 <|> pCase
161 <|> do x <- iName []
162 return (LV (Glob x))
164pLang = do reserved "C"; return LANG_C
166pType = do reserved "Int"; return FInt
167 <|> do reserved "Float"; return FDouble
168 <|> do reserved "String"; return FString
169 <|> do reserved "Unit"; return FUnit
170 <|> do reserved "Ptr"; return FPtr
171 <|> do reserved "Any"; return FAny
173pCase :: LParser LExp
174pCase = do reserved "case"; e <- pLExp; reserved "of"
175 lchar '{'
176 alts <- sepBy1 pAlt (lchar '|')
177 lchar '}'
178 return (LCase e alts)
180pCast :: LParser LExp
181pCast = do reserved "FloatString"; lchar '('; e <- pLExp; lchar ')'
182 return (LOp LFloatStr [e])
183 <|> do reserved "StringFloat"; lchar '('; e <- pLExp; lchar ')'
184 return (LOp LStrFloat [e])
185 <|> do reserved "FloatInt"; lchar '('; e <- pLExp; lchar ')'
186 return (LOp LFloatInt [e])
187 <|> do reserved "IntFloat"; lchar '('; e <- pLExp; lchar ')'
188 return (LOp LIntFloat [e])
189 <|> do reserved "StringInt"; lchar '('; e <- pLExp; lchar ')'
190 return (LOp LStrInt [e])
191 <|> do reserved "IntString"; lchar '('; e <- pLExp; lchar ')'
192 return (LOp LIntStr [e])
193 <|> do reserved "BigInt"; lchar '('; e <- pLExp; lchar ')'
194 return (LOp LBigInt [e])
195 <|> do reserved "IntBig"; lchar '('; e <- pLExp; lchar ')'
196 return (LOp LIntBig [e])
197 <|> do reserved "BigString"; lchar '('; e <- pLExp; lchar ')'
198 return (LOp LBigStr [e])
199 <|> do reserved "StringBig"; lchar '('; e <- pLExp; lchar ')'
200 return (LOp LStrBig [e])
202pPrim :: LParser LExp
203pPrim = do reserved "StrEq"; lchar '(';
204 e <- pLExp; lchar ',';
205 e' <- pLExp; lchar ')';
206 return (LOp LStrEq [e, e'])
207 <|> do reserved "StrLt"; lchar '('
208 e <- pLExp; lchar ','; e' <- pLExp;
209 lchar ')'
210 return (LOp LStrLt [e, e'])
211 <|> do reserved "StrLen"; lchar '('; e <- pLExp; lchar ')';
212 return (LOp LStrLen [e])
213 <|> do reserved "ReadString"; lchar '('; e <- pLExp; lchar ')';
214 return (LOp LReadStr [e])
215 <|> do reserved "WriteString"; lchar '(';
216 e <- pLExp; lchar ')'
217 return (LOp LPrintStr [e])
218 <|> do reserved "WriteInt"; lchar '(';
219 e <- pLExp; lchar ')';
220 return (LOp LPrintNum [e])
221 <|> do reserved "lazy"; lchar '(';
222 e <- pLExp; lchar ')';
223 return (LLazyExp e)
224 <|> do reserved "StrHead"; lchar '('; e <- pLExp; lchar ')';
225 return (LOp LStrHead [e])
226 <|> do reserved "StrTail"; lchar '('; e <- pLExp; lchar ')';
227 return (LOp LStrTail [e])
228 <|> do reserved "StrRev"; lchar '('; e <- pLExp; lchar ')';
229 return (LOp LStrRev [e])
230 <|> do reserved "StrCons"; lchar '('; x <- pLExp; lchar ',';
231 xs <- pLExp; lchar ')';
232 return (LOp LStrCons [x, xs])
233 <|> do reserved "StrIndex"; lchar '('; x <- pLExp; lchar ',';
234 i <- pLExp; lchar ')';
235 return (LOp LStrIndex [x, i])
237pAlt :: LParser LAlt
238pAlt = try (do x <- iName []
239 lchar '('; args <- sepBy1 (iName []) (lchar ','); lchar ')'
240 symbol "=>"
241 rhs <- pLExp
242 return (LConCase (-1) x args rhs))
243 <|> do x <- iName [];
244 symbol "=>"
245 rhs <- pLExp
246 return (LConCase (-1) x [] rhs)
247 <|> do c <- natural
248 symbol "=>"
249 rhs <- pLExp
250 return (LConstCase (I (fromInteger c)) rhs)
251 <|> do symbol "_"
252 symbol "=>"
253 rhs <- pLExp
254 return (LDefaultCase rhs)
257pLConst :: LParser LExp
258pLConst = try (do f <- float; return $ LConst (Fl f))
259 <|> try (do i <- natural; lchar ':'; return $ LConst (BI i))
260 <|> try (do i <- natural; return $ LConst (I (fromInteger i)))
261 <|> try (do s <- strlit; return $ LConst (Str s))
262 <|> try (do c <- chlit; return $ LConst (Ch c))