src/M0ld/Parser.hs

   1 module M0ld.Parser (parseM0ld) where
   2 import Text.ParserCombinators.Parsec hiding (label)
   3 import qualified Data.Map as Map
   4 import M0ld.AST
   5
   6 identifier = do
   7     first <- choice [letter, char '_']
   8     rest <- many $ choice [alphaNum, char '_', char '!']
   9     return $ [first] ++ rest
  10
  11 ws = do
  12     many1 $ choice
  13         [ oneOf "\t\n "
  14         , char '#' >> many (noneOf "\n") >> newline
  15         ]
  16     return [()]
  17
  18 opt_ws = option [()] ws
  19
  20 tok r = do
  21     res <- r
  22     opt_ws
  23     return res
  24
  25 symbol x = tok $ string x
  26
  27 parenthesized = between (symbol "(") (symbol ")")
  28
  29 inBraces = between (symbol "{") (symbol "}")
  30
  31 register =  char '$' >> identifier
  32
  33 label = do
  34     id <- tok $ identifier
  35     symbol ":"
  36     return [LabelDef id]
  37
  38 stmt = do
  39     l <- option [] (try label)
  40     body <- choice $ map try [label,call2,call,decl,goto,br]
  41     return $ l ++ body
  42
  43 constant = choice
  44       [ do
  45           (char '¢') <|> (char '?')
  46           name <- identifier
  47           return $ Var name
  48       , do
  49         digits <- many1 digit
  50         return $ IntegerConstant $ read digits
  51       , do
  52         content <- between (char '"') (char '"') quotedChar
  53         return $ StringConstant $ concat content
  54       , submold
  55       ]
  56       where
  57       quotedChar = many $
  58         do
  59         c <- noneOf "\"\\"
  60         return [c]
  61         <|> do
  62             char '\\'
  63             c <- anyChar
  64             return ['\\',c]
  65
  66 -- implicit_decl :: GenParser Char ImplicitDecls [Char]
  67 implicit_decl = do
  68     c <- constant
  69     decls <- getState
  70     case (Map.lookup c decls) of
  71         Just c -> return c
  72         Nothing ->
  73             do
  74                 let new = "___implicit_register___"++(show $ Map.size decls)
  75                 updateState $ Map.insert c new
  76                 decls <- getState
  77                 return $ new
  78
  79 value = tok $ choice [register,implicit_decl]
  80
  81 decl = do
  82     string "my"
  83     ws
  84     x <- tok register
  85     defaultValue <- option None $ symbol "=" >> constant
  86     return [Decl x defaultValue]
  87
  88 branch = inBraces $ do
  89     string "goto"
  90     ws
  91     label <- tok identifier
  92     option ' ' $ char ';'
  93     return label
  94
  95 br = do
  96     string "if"
  97     ws
  98     cond <- value
  99     iftrue <- branch
 100     symbol "else"
 101     iffalse <- branch
 102     return [Br cond iftrue iffalse]
 103
 104 goto = do
 105     string "goto"
 106     ws
 107     label <- identifier
 108     return [Goto label]
 109
 110 call = do
 111     inline_decl <- option False (symbol "my" >> return True)
 112     target <- value
 113     symbol "="
 114     invocant <- value
 115     char '.'
 116     identifier <- value
 117     arguments <- parenthesized $ sepBy (tok argument) (symbol ",")
 118     let pos = [ x | Pos x <- arguments]
 119         named = [x | (Named k v) <- arguments, x <- [k,v]]
 120         decl = if inline_decl then [Decl target None] else []
 121         call = [Call target identifier (Capture invocant pos named)]
 122     return $ decl ++ call
 123
 124 call2 = do
 125     target <- value
 126     symbol "="
 127     responder <- value
 128     char '.'
 129     identifier <- value
 130     capture <- parenthesized $ symbol "|" >> value
 131     return [Call2 target responder identifier capture]
 132
 133 argument = do
 134         char ':'
 135         k <- value
 136         v <- parenthesized value
 137         return $ Named k v
 138     <|> do
 139         arg <- value
 140         return $ Pos arg
 141
 142 terminator = opt_ws >> ((symbol ";" >> return ()) <|> eof)
 143 top = do
 144     opt_ws
 145     stmts <- tok $ endBy stmt terminator
 146     eof
 147     constants <- getState
 148     return (concat $ stmts,constants)
 149
 150 submold = do
 151     savedState <- getState
 152     setState Map.empty
 153
 154     symbol "mold"
 155     stmts <- inBraces $ tok $ endBy stmt terminator
 156     constants <- getState
 157     setState savedState
 158     return $ SubMold $ (implicitDecls constants) ++ (concat stmts)
 159 type ImplicitDecls = Map.Map Value [Char]
 160
 161 implicitDecls = map (\(constant,reg) -> Decl reg constant) . Map.toList
 162
 163 parseM0ld code =
 164     case (runParser top (Map.empty :: ImplicitDecls) "" code) of
 165         Left err      -> error  $ show err
 166         Right (stmts,constants) -> (implicitDecls constants) ++ stmts