git.iko.soy/Idris-dev
on aa8aefd help sign in
Idris-dev/src/RTS/BCParser.hs
96 lines 3.5 kB history raw
1module RTS.BCParser where
3import Core.CoreParser
4import Core.TT
6import RTS.Bytecode
8import Text.ParserCombinators.Parsec
9import Text.ParserCombinators.Parsec.Error
10import Text.ParserCombinators.Parsec.Expr
11import Text.ParserCombinators.Parsec.Language
12import qualified Text.ParserCombinators.Parsec.Token as PTok
14import Data.List
15import Control.Monad.State
16import Debug.Trace
17import Data.Maybe
18import System.FilePath
20type TokenParser a = PTok.TokenParser a
22type BParser = GenParser Char ()
24lexer :: TokenParser ()
25lexer = PTok.makeTokenParser idrisDef
27whiteSpace= PTok.whiteSpace lexer
28lexeme = PTok.lexeme lexer
29symbol = PTok.symbol lexer
30natural = PTok.natural lexer
31parens = PTok.parens lexer
32semi = PTok.semi lexer
33comma = PTok.comma lexer
34identifier= PTok.identifier lexer
35reserved = PTok.reserved lexer
36operator = PTok.operator lexer
37reservedOp= PTok.reservedOp lexer
38integer = PTok.integer lexer
39float = PTok.float lexer
40strlit = PTok.stringLiteral lexer
41chlit = PTok.charLiteral lexer
42lchar = lexeme.char
44parseFile :: FilePath -> IO BCProg
45parseFile fname = do fp <- readFile fname
46 case runParser pProgram () fname fp of
47 Left err-> fail (show err)
48 Right x -> return x
50pProgram :: BParser BCProg
51pProgram = do fs <- many1 pFun
52 return $ BCProg fs
54pFun :: BParser (Name, Bytecode)
55pFun = do n <- iName []
56 lchar ':'
57 bc <- many1 pInstruction
58 return (n, bc)
60pInstruction :: BParser BCOp
61pInstruction =
62 try (do reserved "PUSH"; v <- pValue; return (PUSH v))
63 <|> try (do reserved "SLIDE"; v <- integer; return (SLIDE (fromInteger v)))
64 <|> try (do reserved "DISCARD"; v <- integer; return (DISCARD (fromInteger v)))
65 <|> try (do reserved "DISCARDINT"; v <- integer
66 return (DISCARDINT (fromInteger v)))
67 <|> try (do reserved "DISCARDFLOAT"; v <- integer
68 return (DISCARDFLOAT (fromInteger v)))
69 <|> try (do reserved "EVAL"; return (EVAL True))
70 <|> try (do reserved "EVAL_NOUPDATE"; return (EVAL False))
71 <|> try (do reserved "MKCON"; t <- integer; a <- integer;
72 return (MKCON (fromInteger t) (fromInteger a)))
73 <|> try (do reserved "MKTHUNK"; n <- iName []; arg <- integer; arity <- integer
74 return (MKTHUNK n (fromInteger arg) (fromInteger arity)))
75 <|> try (do reserved "MKUNIT"; return MKUNIT)
76 <|> try (do reserved "CALL"; n <- iName []; i <- integer;
77 return (CALL n (fromInteger i)))
78 <|> try (do reserved "ERROR"; s <- strlit; return (ERROR s))
79 <|> try (do reserved "SPLIT"; return SPLIT)
80 <|> try (do reserved "DUMP"; return DUMP)
81 <|> do reserved "CASE"; s <- sepBy1 pAlt (lchar '|')
82 def <- option Nothing (do reserved "default"; symbol "->";
83 bc <- many1 pInstruction
84 return (Just bc))
85 return (CASE s def)
86 where pAlt = try (do t <- integer; symbol "->"
87 bc <- many1 pInstruction
88 return (fromInteger t, bc))
90pValue :: BParser SValue
91pValue = try (do x <- integer; lchar 'L'; return (VBigInt x))
92 <|> try (do x <- integer; return (VInt (fromInteger x)))
93 <|> try (do x <- float; return (VFloat x))
94 <|> try (do x <- strlit; return (VString x))
95 <|> try (do x <- chlit; return (VChar x))
96 <|> try (do lchar 'S'; x <- integer; return (VRef (fromInteger x)))