git.iko.soy/Idris-dev
on 4e0fe22 help sign in
Idris-dev/src/IRTS/LParser.hs
213 lines 7.4 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 defs
51 let ctxtIn = addAlist tagged emptyContext
52 let defuns = defunctionalise nexttag ctxtIn
53-- print 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 LFTimes [x,y]) AssocLeft
92 ],
93 [
94 binary "+" (\x y -> LOp LPlus [x,y]) AssocLeft,
95 binary "-" (\x y -> LOp LMinus [x,y]) AssocLeft,
96 binary "++" (\x y -> LOp LStrConcat [x,y]) AssocLeft,
97 binary "+." (\x y -> LOp LFPlus [x,y]) AssocLeft,
98 binary "-." (\x y -> LOp LFMinus [x,y]) AssocLeft
99 ],
100 [
101 binary "==" (\x y -> LOp LEq [x, y]) AssocNone,
102 binary "==." (\x y -> LOp LFEq [x, y]) AssocNone,
103 binary "<" (\x y -> LOp LLt [x, y]) AssocNone,
104 binary "<." (\x y -> LOp LFLt [x, y]) AssocNone,
105 binary ">" (\x y -> LOp LGt [x, y]) AssocNone,
106 binary ">." (\x y -> LOp LFGt [x, y]) AssocNone,
107 binary "<=" (\x y -> LOp LLe [x, y]) AssocNone,
108 binary "<=." (\x y -> LOp LFLe [x, y]) AssocNone,
109 binary ">=" (\x y -> LOp LGe [x, y]) AssocNone,
110 binary ">=." (\x y -> LOp LFGe [x, y]) AssocNone
111 ]]
113binary name f assoc = Infix (do reservedOp name; return f) assoc
115pLExp' :: LParser LExp
116pLExp' = try (do lchar '%'; pCast)
117 <|> try (do lchar '%'; pPrim)
118 <|> try (do tc <- option False (do lchar '%'; reserved "tc"; return True)
119 x <- iName [];
120 lchar '('
121 args <- sepBy pLExp (lchar ',')
122 lchar ')'
123 if null args then return (LV (Glob x)) else return (LApp tc x args))
124 <|> do lchar '('; e <- pLExp; lchar ')'; return e
125 <|> pLConst
126 <|> do reserved "let"; x <- iName []; lchar '='; v <- pLExp
127 reserved "in"; e <- pLExp
128 return (LLet x v e)
129 <|> do reserved "foreign"; l <- pLang; t <- pType
130 fname <- strlit
131 lchar '('
132 fargs <- sepBy (do t' <- pType; e <- pLExp; return (t', e)) (lchar ',')
133 lchar ')'
134 return (LForeign l t fname fargs)
135 <|> pCase
136 <|> do x <- iName []
137 return (LV (Glob x))
139pLang = do reserved "C"; return LANG_C
141pType = do reserved "Int"; return FInt
142 <|> do reserved "Float"; return FDouble
143 <|> do reserved "String"; return FString
144 <|> do reserved "Unit"; return FUnit
145 <|> do reserved "Ptr"; return FPtr
146 <|> do reserved "Any"; return FAny
148pCase :: LParser LExp
149pCase = do reserved "case"; e <- pLExp; reserved "of"
150 lchar '{'
151 alts <- sepBy1 pAlt (lchar '|')
152 lchar '}'
153 return (LCase e alts)
155pCast :: LParser LExp
156pCast = do reserved "FloatString"; lchar '('; e <- pLExp; lchar ')'
157 return (LOp LFloatStr [e])
158 <|> do reserved "StringFloat"; lchar '('; e <- pLExp; lchar ')'
159 return (LOp LStrFloat [e])
160 <|> do reserved "FloatInt"; lchar '('; e <- pLExp; lchar ')'
161 return (LOp LFloatInt [e])
162 <|> do reserved "IntFloat"; lchar '('; e <- pLExp; lchar ')'
163 return (LOp LIntFloat [e])
164 <|> do reserved "StringInt"; lchar '('; e <- pLExp; lchar ')'
165 return (LOp LStrInt [e])
166 <|> do reserved "IntString"; lchar '('; e <- pLExp; lchar ')'
167 return (LOp LIntStr [e])
169pPrim :: LParser LExp
170pPrim = do reserved "StrEq"; lchar '(';
171 e <- pLExp; lchar ',';
172 e' <- pLExp; lchar ')';
173 return (LOp LStrEq [e, e'])
174 <|> do reserved "StrLt"; lchar '('
175 e <- pLExp; lchar ','; e' <- pLExp;
176 lchar ')'
177 return (LOp LStrLt [e, e'])
178 <|> do reserved "StrLen"; lchar '('; e <- pLExp; lchar ')';
179 return (LOp LStrLen [e])
180 <|> do reserved "ReadString"; return (LOp LReadStr [])
181 <|> do reserved "WriteString"; lchar '(';
182 e <- pLExp; lchar ')'
183 return (LOp LPrintStr [e])
184 <|> do reserved "WriteInt"; lchar '(';
185 e <- pLExp; lchar ')';
186 return (LOp LPrintNum [e])
188pAlt :: LParser LAlt
189pAlt = try (do x <- iName []
190 lchar '('; args <- sepBy1 (iName []) (lchar ','); lchar ')'
191 symbol "=>"
192 rhs <- pLExp
193 return (LConCase (-1) x args rhs))
194 <|> do x <- iName [];
195 symbol "=>"
196 rhs <- pLExp
197 return (LConCase (-1) x [] rhs)
198 <|> do c <- natural
199 symbol "=>"
200 rhs <- pLExp
201 return (LConstCase (I (fromInteger c)) rhs)
202 <|> do symbol "_"
203 symbol "=>"
204 rhs <- pLExp
205 return (LDefaultCase rhs)
208pLConst :: LParser LExp
209pLConst = try (do f <- float; return $ LConst (Fl f))
210 <|> try (do i <- natural; return $ LConst (I (fromInteger i)))
211 <|> try (do s <- strlit; return $ LConst (Str s))
212 <|> try (do c <- chlit; return $ LConst (Ch c))