git.iko.soy/Idris-dev
on 3812df8 help sign in
Idris-dev/src/IRTS/LParser.hs
204 lines 7.0 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 Paths_idris
11import Text.ParserCombinators.Parsec
12import Text.ParserCombinators.Parsec.Error
13import Text.ParserCombinators.Parsec.Expr
14import Text.ParserCombinators.Parsec.Language
15import qualified Text.ParserCombinators.Parsec.Token as PTok
17import Data.List
18import Control.Monad.State
19import Debug.Trace
20import Data.Maybe
21import System.FilePath
23type TokenParser a = PTok.TokenParser a
25type LParser = GenParser Char ()
27lexer :: TokenParser ()
28lexer = PTok.makeTokenParser idrisDef
30whiteSpace= PTok.whiteSpace lexer
31lexeme = PTok.lexeme lexer
32symbol = PTok.symbol lexer
33natural = PTok.natural lexer
34parens = PTok.parens lexer
35semi = PTok.semi lexer
36comma = PTok.comma lexer
37identifier= PTok.identifier lexer
38reserved = PTok.reserved lexer
39operator = PTok.operator lexer
40reservedOp= PTok.reservedOp lexer
41integer = PTok.integer lexer
42float = PTok.float lexer
43strlit = PTok.stringLiteral lexer
44chlit = PTok.charLiteral lexer
45lchar = lexeme.char
47fovm :: FilePath -> IO ()
48fovm f = do defs <- parseFOVM f
49 codegenC defs "a.out" True ["math.h"] "" TRACE
51parseFOVM :: FilePath -> IO [(Name, LDecl)]
52parseFOVM fname = do -- putStrLn $ "Reading " ++ fname
53 fp <- readFile fname
54 case runParser pProgram () fname fp of
55 Left err-> fail (show err)
56 Right x -> return x
58pProgram :: LParser [(Name, LDecl)]
59pProgram = do fs <- many1 pLDecl
60 eof
61 return fs
63pLDecl :: LParser (Name, LDecl)
64pLDecl = do reserved "data"
65 n <- iName []
66 ar <- natural
67 return (n, LConstructor n (-1) (fromInteger ar))
68 <|> do reserved "fun"
69 n <- iName []
70 lchar '('
71 args <- sepBy (iName []) (lchar ',')
72 lchar ')'
73 lchar '='
74 def <- pLExp
75 return (n, LFun n args def)
77pLExp = buildExpressionParser optable pLExp'
79optable = [[binary "*" (\x y -> LOp LTimes [x,y]) AssocLeft,
80 binary "/" (\x y -> LOp LDiv [x,y]) AssocLeft,
81 binary "*." (\x y -> LOp LFTimes [x,y]) AssocLeft,
82 binary "/." (\x y -> LOp LFTimes [x,y]) AssocLeft
83 ],
84 [
85 binary "+" (\x y -> LOp LPlus [x,y]) AssocLeft,
86 binary "-" (\x y -> LOp LMinus [x,y]) AssocLeft,
87 binary "++" (\x y -> LOp LStrConcat [x,y]) AssocLeft,
88 binary "+." (\x y -> LOp LFPlus [x,y]) AssocLeft,
89 binary "-." (\x y -> LOp LFMinus [x,y]) AssocLeft
90 ],
91 [
92 binary "==" (\x y -> LOp LEq [x, y]) AssocNone,
93 binary "==." (\x y -> LOp LFEq [x, y]) AssocNone,
94 binary "<" (\x y -> LOp LLt [x, y]) AssocNone,
95 binary "<." (\x y -> LOp LFLt [x, y]) AssocNone,
96 binary ">" (\x y -> LOp LGt [x, y]) AssocNone,
97 binary ">." (\x y -> LOp LFGt [x, y]) AssocNone,
98 binary "<=" (\x y -> LOp LLe [x, y]) AssocNone,
99 binary "<=." (\x y -> LOp LFLe [x, y]) AssocNone,
100 binary ">=" (\x y -> LOp LGe [x, y]) AssocNone,
101 binary ">=." (\x y -> LOp LFGe [x, y]) AssocNone
102 ]]
104binary name f assoc = Infix (do reservedOp name; return f) assoc
106pLExp' :: LParser LExp
107pLExp' = try (do lchar '%'; pCast)
108 <|> try (do lchar '%'; pPrim)
109 <|> try (do tc <- option False (do lchar '%'; reserved "tc"; return True)
110 x <- iName [];
111 lchar '('
112 args <- sepBy pLExp (lchar ',')
113 lchar ')'
114 if null args then return (LV (Glob x)) else return (LApp tc x args))
115 <|> do lchar '('; e <- pLExp; lchar ')'; return e
116 <|> pLConst
117 <|> do reserved "let"; x <- iName []; lchar '='; v <- pLExp
118 reserved "in"; e <- pLExp
119 return (LLet x v e)
120 <|> do reserved "foreign"; l <- pLang; t <- pType
121 fname <- strlit
122 lchar '('
123 fargs <- sepBy (do t' <- pType; e <- pLExp; return (t', e)) (lchar ',')
124 lchar ')'
125 return (LForeign l t fname fargs)
126 <|> pCase
127 <|> do x <- iName []
128 return (LV (Glob x))
130pLang = do reserved "C"; return LANG_C
132pType = do reserved "Int"; return FInt
133 <|> do reserved "Float"; return FDouble
134 <|> do reserved "String"; return FString
135 <|> do reserved "Unit"; return FUnit
136 <|> do reserved "Ptr"; return FPtr
137 <|> do reserved "Any"; return FAny
139pCase :: LParser LExp
140pCase = do reserved "case"; e <- pLExp; reserved "of"
141 lchar '{'
142 alts <- sepBy1 pAlt (lchar '|')
143 lchar '}'
144 return (LCase e alts)
146pCast :: LParser LExp
147pCast = do reserved "FloatString"; lchar '('; e <- pLExp; lchar ')'
148 return (LOp LFloatStr [e])
149 <|> do reserved "StringFloat"; lchar '('; e <- pLExp; lchar ')'
150 return (LOp LStrFloat [e])
151 <|> do reserved "FloatInt"; lchar '('; e <- pLExp; lchar ')'
152 return (LOp LFloatInt [e])
153 <|> do reserved "IntFloat"; lchar '('; e <- pLExp; lchar ')'
154 return (LOp LIntFloat [e])
155 <|> do reserved "StringInt"; lchar '('; e <- pLExp; lchar ')'
156 return (LOp LStrInt [e])
157 <|> do reserved "IntString"; lchar '('; e <- pLExp; lchar ')'
158 return (LOp LIntStr [e])
160pPrim :: LParser LExp
161pPrim = do reserved "StrEq"; lchar '(';
162 e <- pLExp; lchar ',';
163 e' <- pLExp; lchar ')';
164 return (LOp LStrEq [e, e'])
165 <|> do reserved "StrLt"; lchar '('
166 e <- pLExp; lchar ','; e' <- pLExp;
167 lchar ')'
168 return (LOp LStrLt [e, e'])
169 <|> do reserved "StrLen"; lchar '('; e <- pLExp; lchar ')';
170 return (LOp LStrLen [e])
171 <|> do reserved "ReadString"; return (LOp LReadStr [])
172 <|> do reserved "WriteString"; lchar '(';
173 e <- pLExp; lchar ')'
174 return (LOp LPrintStr [e])
175 <|> do reserved "WriteInt"; lchar '(';
176 e <- pLExp; lchar ')';
177 return (LOp LPrintNum [e])
179pAlt :: LParser LAlt
180pAlt = try (do x <- iName []
181 lchar '('; args <- sepBy1 (iName []) (lchar ','); lchar ')'
182 symbol "=>"
183 rhs <- pLExp
184 return (LConCase (-1) x args rhs))
185 <|> do x <- iName [];
186 symbol "=>"
187 rhs <- pLExp
188 return (LConCase (-1) x [] rhs)
189 <|> do c <- natural
190 symbol "=>"
191 rhs <- pLExp
192 return (LConstCase (I (fromInteger c)) rhs)
193 <|> do symbol "_"
194 symbol "=>"
195 rhs <- pLExp
196 return (LDefaultCase rhs)
199pLConst :: LParser LExp
200pLConst = try (do f <- float; return $ LConst (Fl f))
201 <|> try (do i <- natural; return $ LConst (I (fromInteger i)))
202 <|> try (do s <- strlit; return $ LConst (Str s))
203 <|> try (do c <- chlit; return $ LConst (Ch c))