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