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