--- /dev/null
+-------------------------------------------------------------
+-- Parser for WHILE from Nielson, Nielson and Hankin
+-- and various other sources.
+-------------------------------------------------------------
+
+module While( prettyWhileFromFile ) where
+
+import WhileAS
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Expr
+import qualified Text.ParserCombinators.Parsec.Token as P
+import Text.ParserCombinators.Parsec.Language( javaStyle )
+
+
+prettyWhileFromFile fname
+ = do{ input <- readFile fname
+ ; putStr input
+ ; case parse program fname input of
+ Left err -> do{ putStr "parse error at "
+ ; print err
+ }
+ Right x -> print x
+ }
+
+--renum :: Prog -> Prog
+--renum p = rn (1,p)
+--rn :: (Int, Stat) -> (Int, Stat)
+--rn (x,s) = case s of
+-- Assign vi ae _ -> (x+1,Assign vi ae x)
+-- Skip _ -> (x+1, Skip x)
+-- Seq [Stat] ->
+-- If be _ s1 s2 -> do{ (newx, newthen) <- rn (x+1,s1)
+-- ; (newerx, newelse) <- rn (newx,s2)
+-- ; return (newerx, If be x newthen newelse)
+-- }
+-- While be _ s -> do{ (newx, news) <- rn (x+1,s)
+-- ; return (newx, While be x+1 news)
+-- }
+
+-----------------------------------------------------------
+-- A program is simply an expression.
+-----------------------------------------------------------
+program
+ = do{ stats <- semiSep1 stat
+ ; return (if length stats < 2 then head stats else Seq stats)
+ }
+
+stat :: Parser Stat
+stat = choice
+ [ do { reserved "skip";
+ return (Skip 0)
+ }
+ , ifStat
+ , whileStat
+ , sequenceStat
+ , try assignStat
+ ]
+
+
+assignStat :: Parser Stat
+assignStat = do{ id <- identifier
+ ; symbol ":="
+ ; s <- aritExpr
+ ; return (Assign id s 0)
+ }
+
+ifStat :: Parser Stat
+ifStat = do{ reserved "if"
+ ; cond <- boolExpr
+ ; reserved "then"
+ ; thenpart <- stat
+ ; reserved "else"
+ ; elsepart <- stat
+ ; return (If cond 0 thenpart elsepart)
+ }
+
+whileStat :: Parser Stat
+whileStat = do{ reserved "while"
+ ; cond <- boolExpr
+ ; reserved "do"
+ ; body <- stat
+ ; return (While cond 0 body)
+ }
+
+sequenceStat :: Parser Stat
+sequenceStat = do{ stats <- parens (semiSep1 stat)
+ ; return (if length stats < 2 then head stats else Seq stats)
+ }
+
+boolExpr:: Parser BExp
+boolExpr = buildExpressionParser boolOperators relExpr
+
+relExpr :: Parser BExp
+relExpr = do{ arg1 <- aritExpr
+ ; op <- choice [string "=", try (string "<>"), try (string "<="), string "<", try (string ">="), string ">"]
+ ; arg2 <- aritExpr
+ ; return (RelOp op arg1 arg2)
+ }
+
+aritExpr :: Parser AExp
+aritExpr = buildExpressionParser aritOperators simpleArit
+
+-- Everything mapping bools to bools
+boolOperators =
+ [ [ prefix "not"]
+ , [ opbb "and" AssocRight ] -- right for shortcircuit
+ , [ opbb "or" AssocRight ] -- right for shortcircuit
+ ]
+ where
+ opbb name assoc = Infix (do{ reservedOp name
+ ; return (\x y -> BOp name x y)
+ }) assoc
+ prefix name = Prefix (do{ reservedOp name
+ ; return (\x -> BUnOp name x)
+ })
+
+-- Everything mapping pairs of ints to ints
+aritOperators =
+ [ [ op "*" AssocLeft, op "/" AssocLeft ]
+ , [ op "+" AssocLeft, op "-" AssocLeft ]
+ , [ op "&" AssocRight ] -- bitwise and delivering an int
+ , [ op "|" AssocRight ] -- bitwise or delivering an int
+ ]
+ where
+ op name assoc = Infix (do{ reservedOp name
+ ; return (\x y -> AOp name x y)
+ }) assoc
+
+
+simpleArit = choice [ intLiteral
+ , parens aritExpr
+ , variable
+ ]
+
+simpleBool = choice [ boolLiteral
+ , parens boolExpr
+ ]
+
+boolLiteral = do{ reserved "false"
+ ; return (BoolLit True)
+ }
+ <|>
+ do{ reserved "true"
+ ; return (BoolLit False)
+ }
+
+intLiteral = do{ i <- integer; return (IntLit i) }
+variable = do{ id <- identifier
+ ; return (Var id)
+ }
+
+
+-----------------------------------------------------------
+-- The lexer
+-----------------------------------------------------------
+lexer = P.makeTokenParser whileDef
+
+whileDef = javaStyle
+ { -- Kept the Java single line comments, but officially the language has no comments
+ P.reservedNames = [ "true", "false", "do", "else", "not",
+ "if", "then", "while", "skip"
+ -- , "begin", "proc", "is", "end", "val", "res", "malloc"
+ ]
+ , P.reservedOpNames= [ "and", "or", "not", "<", "<=", ">", ">=", ":=", "+", "&", "-", "/"]
+ , P.opLetter = oneOf (concat (P.reservedOpNames whileDef))
+ , P.caseSensitive = False
+ }
+
+parens = P.parens lexer
+braces = P.braces lexer
+semiSep1 = P.semiSep1 lexer
+whiteSpace = P.whiteSpace lexer
+symbol = P.symbol lexer
+identifier = P.identifier lexer
+reserved = P.reserved lexer
+reservedOp = P.reservedOp lexer
+integer = P.integer lexer
+charLiteral = P.charLiteral lexer
+stringLiteral = P.stringLiteral lexer
projects / haskell-directory.git / blobdiff