Skip to content

GitLab

Commit bc551bec authored by matthew-eads's avatar matthew-eads
Browse files

bug fixes, kinda produces a working grammar

parent 85394105
Hide whitespace changes
Inline Side-by-side
src/AST.hs
View file @ bc551bec
......@@ -16,7 +16,6 @@ import Text.Regex
import Data.List.Unique
import Data.List
import Data.List.Split
import Data.Char
import FileStrings (makeParser, makeLexer)
type Directive = String
......@@ -46,8 +45,7 @@ dataDToDecT :: Dec -> (DecT, String)
dataDToDecT (DataD _ {- cxt -} name _ {- tvb -} constructors _ {- derives -}) =
let rhss = (map conToRHS constructors)
in (DecT (showName name) (map (\(x,_) -> x) rhss),
(foldr (\(_,y) acc -> "\n" ++ y ++ acc) "" rhss))
(foldr (\(_,y) acc -> "\n" ++ y ++ acc) "" rhss))
dataDToDecT _ = error "dataDtoDecT applied to non-data dec"
-- Converts Haskell Con type (right hand sides in a data declaration)
......@@ -85,7 +83,7 @@ stypeToString (_, (AppT (ConT n) t)) =
stypeToString (_, (AppT t1 t2)) =
let ts = flattenTuple t1 t2
ts' = map (stypeToString . (\x -> (IsStrict, x))) ts
(s, rs) = ((foldr (\(x, _) a -> (fixMultis x) ++ "\\" ++ a) "" ts'),
(s, rs) = ((foldr (\(x, _) a -> x ++ "\\" ++ a) "" ts'),
(foldr (\(_, y) a -> y ++ a) "" ts'))
rs' = rs ++ "\n" ++ (makeTupleRules s)
in ((filter ((/=) '\\') s), rs')
......@@ -131,27 +129,6 @@ rrhs (RHS' s ts _) = "\t{" ++ s ++ " " ++ (makeNums (length ts) (length ts) " ")
rrhsL :: String -> [Int] -> String
rrhsL name ints = "\t{" ++ name ++ " " ++ (makeNumsL ints) ++ "}"
isMulti :: String -> Bool
isMulti "*" = True
isMulti "+" = True
isMulti [] = False
isMulti (_:r) = isMulti r
isMulti0 :: String -> Bool
isMulti0 "*" = True
isMulti0 [] = False
isMulti0 (_:r) = isMulti0 r
isMulti1 :: String -> Bool
isMulti1 "+" = True
isMulti1 [] = False
isMulti1 (_:r) = isMulti1 r
fixMultis :: String -> String
fixMultis s = (if isMulti1 s then "Multi1"
else if isMulti0 s then "Multi0"
else "") ++ (strip s)
nums0 :: Int -> [Int]
nums0 0 = []
nums0 n = (nums0 (n-1)) ++ [n]
......@@ -163,26 +140,32 @@ nums1 n = (nums1 (n-1)) ++ [n+1]
rhsToRule :: [RHS'] -> RHS' -> (String, [String])
rhsToRule rules =
\(RHS' s ts d) ->
let ts' = (map fixMultis ts)
let ts' = ts
in
(case d of
"" -> if (isUnique rules (RHS' s ts d))
then ((foldr myappend "" ts') ++ (rrhsL s (nums0 (length ts))), [])
else ("\"" ++ s ++ "\" " ++ (foldr myappend "" ts') ++ (rrhsL s (nums1 (length ts))),
else (s ++ " " ++ (foldr myappend "" ts') ++ (rrhsL s (nums1 (length ts))),
[s])
"if" -> if length ts == 2
then ("\"if\" " ++ (head ts) ++ " \"then\" " ++ (head (tail ts))
++ (rrhsL s [2,4]), [])
then ("if " ++ (head ts) ++ " \"then\" " ++ (head (tail ts))
++ (rrhsL s [2,4]), ["if", "then"])
else if length ts == 3
then ("\"if\" " ++ (head ts) ++ " \"then\" " ++ (head (tail ts))
++ " \"else\" " ++ (head (tail (tail ts))) ++ (rrhsL s [2,4,6]),
[])
then ("if " ++ (head ts) ++ " then " ++ (head (tail ts))
++ " else " ++ (head (tail (tail ts))) ++ (rrhsL s [2,4,6]), ["if", "then", "else"])
else error "bad number of constructions for if rule"
"ifelse" -> if length ts == 3
then ("if " ++ (head ts) ++ " then " ++ (head (tail ts))
++ " else " ++ (head (tail (tail ts))) ++ (rrhsL s [2,4,6]), ["if", "then", "else"])
else error "bad number of constructions for if rule"
"while" -> ("\"while\" \"(\"" ++ (head ts) ++ " \")\" \"{\" " ++ (head (tail ts))
++ " \"}\"" ++ (rrhsL s [3, 6]), [])
"while" -> ("while LParen " ++ (head ts) ++ " RParen LBrace " ++ (head (tail ts))
++ " RBrace" ++ (rrhsL s [3, 6]), ["while"])
('i':'n':'f':'i':'x':rest) ->
let op = cleanWS rest
(op', t) = if op == "" then (" \"" ++ s ++ "\" ", [s]) else (" "++op++" ", [])
(op', t) = if op == "" then (" "++s++" ", [s]) else
(case op of
"+" -> (" Plus ", ["Plus"])
_ -> (" FSlash ", ["FSlash"]))
in ((head ts) ++ op' ++ (head (tail ts)) ++ (rrhsL s [1,3]), t)
bad -> error ("directive " ++ bad ++ " not supported"))
......@@ -231,7 +214,8 @@ decTToRule (DecT' n rhs) =
makeRules :: [DecT'] -> (String, [String])
makeRules decs = (foldr (\r (r', ts') ->
let (rule, tokes) = (decTToRule r)
in ((rule ++ "\n" ++ r'), (ts' ++ tokes))) ("",[]) decs)
in ((rule ++ "\n" ++ r'), (ts' ++ tokes))) ("",
["LParen", "RParen", "RBrace", "LBrace", "Plus", "Star", "FSlash", "Dash"]) decs)
cleanNLs' :: String -> String
cleanNLs' ('\n':'\n':'\n':s) = cleanNLs' ('\n':'\n':s)
......
src/FileStrings.hs
View file @ bc551bec
module FileStrings where
import Data.Char
import Data.List
cleanNLs' :: String -> String
cleanNLs' ('\n':'\n':'\n':s) = cleanNLs' ('\n':'\n':s)
......@@ -11,7 +12,7 @@ cleanNLs s = cleanNLs' (dropWhile ((==) '\n') s)
makeParser :: String -> [String] -> String -> String -> String
makeParser name tokes grammar ast =
let tokenRules = cleanNLs $ foldr (\t a -> "\"" ++ t ++ "\""
let tokenRules = cleanNLs $ foldr (\t a -> t
++ " { " ++ "Token" ++ ((toUpper (head t)):(tail t)) ++
" }\n" ++ a) "" tokes
in
......@@ -23,28 +24,25 @@ makeParser name tokes grammar ast =
tokenRules ++
"Int { TokenInt $$ }\n" ++
"ID { TokenID $$ }\n" ++
"set { TokenSet }\n" ++
"if { TokenIf}\n" ++
"plus { TokenPlus}\n" ++
"while { TokenWhile }\n" ++
"begin { TokenBegin }\n" ++
"String { TokenString $$ }\n" ++
"eof { TokenEOF }\n" ++
"nl { TokenNL }\n" ++
"%error {parseError}\n\n%%\n\n" ++
grammar ++
"\n{\n" ++ ast ++
"\n{\ntype List1 a = [a]\ntype List0 a = [a]\n" ++ ast ++
"\nparseError :: [Token] -> a\n" ++
"parseError t = error (\"Parse Error on token(s) \" ++ (show t))\n\n" ++
"type ID = String\n}\n"
"}\n"
makeLexer :: String -> [String] -> String
makeLexer name tokes =
let tokenRules = cleanNLs $ foldr (\t a ->
let f = \x -> if null x then x else ((toUpper (head x)):(tail x))
tokenRules = cleanNLs $ foldr (\t a ->
"<0> " ++ '"':t ++ "\"\t{ \\(pos,_,_,inp) len -> return Token"
++ ((toUpper (head t)):(tail t)) ++ " :: Alex Token }\n" ++ a) "" tokes
dataRules = cleanNLs $ foldr (\t a -> "\t| Token" ++ ((toUpper (head t)):(tail t))
++ "\n" ++ a) "" tokes
++ "\n" ++ a) "" (nub (map f (tokes ++ ["Set ", "If", "Then", "Else", "While", "Begin", "Var", "EOF ", "NL", "LParen", "RParen", "LT", "GT", "LE", "GE", "Bang", "At", "Pound", "Dollar", "Percent", "Carat", "Ampersand", "Star", "Dash", "Underscore", "Plus", "Eq", "LBrace", "RBrace", "LBrack", "RBrack", "FSlash", "BSlash", "SemiColon", "Colon", "DoubleQuote", "SingleQuote", "Comma", "Period", "Question", "Tilda", "Tick", "Bar"])))
in ("{\nmodule " ++ name ++ "Lexer (runLexer, Token (..)) where\n" ++
"import Debug.Trace\n}\n\n" ++
"%wrapper \"monad\"\n\n" ++
......@@ -63,17 +61,17 @@ makeLexer name tokes =
"<0> @string { \\(pos,_,_,inp) len -> return $ TokenString (take len inp) }\n\n" ++
"<0> @identifier { \\(pos,_,_,inp) len -> return $ TokenID (take len inp) }\n\n"
++ tokenRules ++
"<0> \"=\"\t { \\(pos,_,_,inp) len -> return $ TokenEq }\n" ++
"<0> \"+\" { \\(pos,_,_,inp) len -> return $ TokenPlus }\n" ++
"<0> \"-\" { \\(pos,_,_,inp) len -> return $ TokenDash }\n" ++
"<0> \"_\" { \\(pos,_,_,inp) len -> return $ TokenUnderscore }\n" ++
"<0> \"\\[\" { \\(pos,_,_,inp) len -> return $ TokenLBrack }\n" ++
"<0> \"\\]\" { \\(pos,_,_,inp) len -> return $ TokenRBrack }\n" ++
"<0> \";\" { \\(pos,_,_,inp) len -> return $ TokenSemiColon }\n" ++
"<0> \">\" { \\(pos,_,_,inp) len -> return $ TokenGT }\n" ++
"<0> \"(\" { \\(pos,_,_,inp) len -> return $ TokenLParen }\n" ++
"<0> \")\" { \\(pos,_,_,inp) len -> return $ TokenRParen }\n" ++
"<0> \"\n\" { \\(pos,_,_,inp) len -> return $ TokenNL }\n" ++
"<0> \"=\"\t { \\(pos,_,_,inp) len -> return $ TokenEq :: Alex Token}\n" ++
"<0> \"+\" { \\(pos,_,_,inp) len -> return $ TokenPlus :: Alex Token}\n" ++
"<0> \"-\" { \\(pos,_,_,inp) len -> return $ TokenDash :: Alex Token}\n" ++
"<0> \"_\" { \\(pos,_,_,inp) len -> return $ TokenUnderscore :: Alex Token}\n" ++
"<0> \"\\[\" { \\(pos,_,_,inp) len -> return $ TokenLBrack :: Alex Token}\n" ++
"<0> \"\\]\" { \\(pos,_,_,inp) len -> return $ TokenRBrack :: Alex Token}\n" ++
"<0> \";\" { \\(pos,_,_,inp) len -> return $ TokenSemiColon :: Alex Token}\n" ++
"<0> \">\" { \\(pos,_,_,inp) len -> return $ TokenGT :: Alex Token}\n" ++
"<0> \"(\" { \\(pos,_,_,inp) len -> return $ TokenLParen :: Alex Token}\n" ++
"<0> \")\" { \\(pos,_,_,inp) len -> return $ TokenRParen :: Alex Token}\n" ++
"<0> \"\\n\" { \\(pos,_,_,inp) len -> return $ TokenNL :: Alex Token}\n" ++
"<0> set { \\(pos,_,_,inp) len -> return $ TokenSet :: Alex Token}\n" ++
"<0> if { \\(pos,_,_,inp) len -> return $ TokenIf :: Alex Token }\n" ++
"<0> then { \\(pos,_,_,inp) len -> return $ TokenThen :: Alex Token }\n" ++
......@@ -118,52 +116,9 @@ makeLexer name tokes =
"alexEOF = return TokenEOF\n\n" ++
"lexwrap = (alexMonadScan >>=)\n\n" ++
"data Token = TokenID String \n" ++
" | TokenSet \n" ++
" | TokenIf\n" ++
" | TokenThen\n" ++
" | TokenElse\n" ++
" | TokenWhile\n" ++
" | TokenBegin\n" ++
" | TokenInt Int\n" ++
" | TokenVar\n" ++
" | TokenString String \n" ++
" | TokenEOF \n" ++
" | TokenNL \n" ++
" | TokenLParen\n" ++
" | TokenRParen\n" ++
" | TokenLT\n" ++
" | TokenGT\n" ++
" | TokenLE\n" ++
" | TokenGE\n" ++
" | TokenBang\n" ++
" | TokenAt\n" ++
" | TokenPound\n" ++
" | TokenDollar\n" ++
" | TokenPercent\n" ++
" | TokenCarat\n" ++
" | TokenAmpersand\n" ++
" | TokenStar\n" ++
" | TokenDash\n" ++
" | TokenUnderscore\n" ++
" | TokenPlus\n" ++
" | TokenEq\n" ++
" | TokenLBrace\n" ++
" | TokenRBrace\n" ++
" | TokenLBrack\n" ++
" | TokenRBrack\n" ++
" | TokenFSlash\n" ++
" | TokenBSlash\n" ++
" | TokenSemiColon\n" ++
" | TokenColon\n" ++
" | TokenDoubleQuote\n" ++
" | TokenSingleQuote\n" ++
" | TokenComma\n" ++
" | TokenPeriod\n" ++
" | TokenQuestion\n" ++
" | TokenTilda\n" ++
" | TokenTick\n" ++
" | TokenBar\n "
++ dataRules ++
" | TokenString String \n" ++
" | TokenInt Int \n" ++
dataRules ++
" deriving (Eq, Show)\n\n" ++
"tokens str = runAlex str $ do\n" ++
" let loop = do tok <- alexMonadScan\n" ++
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment