Created
November 29, 2018 14:31
-
-
Save jerguslejko/38352dc1fc5ec809e840ee203fe3b956 to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| import Text.Yoda | |
| import Prelude hiding (Num) | |
| main :: IO () | |
| main = return () | |
| class Pretty a where | |
| pretty :: a -> String | |
| check :: (Eq a, Pretty a) => Parser a -> String -> Bool | |
| check p xs = f == s where | |
| f = parse p xs | |
| s = parse p (pretty (fst $ f !! 0)) | |
| whitespace :: Parser () | |
| whitespace = skip (many (oneOf [' ','\t','\n'])) | |
| number :: Parser Int | |
| number = read <$> some (oneOf ['0'..'9']) <* whitespace | |
| word :: Parser String | |
| word = some (oneOf ['a'..'z']) <* whitespace | |
| token :: String -> Parser String | |
| token t = string t <* whitespace | |
| data AExp = Add AExp AExp | |
| | Sub AExp AExp | |
| | ATerm ATerm | |
| deriving (Show, Eq) | |
| data ATerm = Mul ATerm ATerm | |
| | Atom Atom | |
| deriving (Show, Eq) | |
| data Atom = ANum Num | |
| | AVar Var | |
| | ABrc AExp | |
| deriving (Show, Eq) | |
| data BExp = And BExp BExp | |
| | BTerm BTerm | |
| deriving (Show, Eq) | |
| data BTerm = Not BTerm | |
| | BTom BTom | |
| deriving (Show, Eq) | |
| data BTom = Lt AExp AExp | |
| | Eq AExp AExp | |
| | BTrue | |
| | BFalse | |
| | BBrc BExp | |
| deriving (Show, Eq) | |
| data Var = Var String | |
| deriving (Show, Eq) | |
| data Num = Num Int | |
| deriving (Show, Eq) | |
| data While = WhileLang Stms | |
| deriving (Show, Eq) | |
| data Stms = Semi Stms Stms | |
| | Stm Stm | |
| deriving (Show, Eq) | |
| data Stm = Skip | |
| | Def Var AExp | |
| | SBrc Stms | |
| | If BExp Stm Stm | |
| | While BExp Stm | |
| deriving (Show, Eq) | |
| var :: Parser Var | |
| var = Var <$> word | |
| num :: Parser Num | |
| num = Num <$> number | |
| lang :: Parser While | |
| lang = WhileLang <$> stms <* eof | |
| stms :: Parser Stms | |
| stms = chainr1 stms' (Semi <$ token ";") | |
| stms' :: Parser Stms | |
| stms' = Stm <$> stm | |
| stm :: Parser Stm | |
| stm = Skip <$ token "skip" | |
| <|> Def <$> var <* token ":=" <*> aexp | |
| <|> SBrc <$ token "(" <*> stms <* token ")" | |
| <|> If <$ token "if" <*> bexp <* token "then" <*> stm <* token "else" <*> stm | |
| <|> While <$ token "while" <*> bexp <* token "do" <*> stm | |
| atom :: Parser Atom | |
| atom = ANum <$> num | |
| <|> AVar <$> var | |
| <|> ABrc <$ token "(" <*> aexp <* token ")" | |
| aexp :: Parser AExp | |
| aexp = chainl1 aexp' (Add <$ token "+" <|> Sub <$ token "-") | |
| aexp' :: Parser AExp | |
| aexp' = ATerm <$> aterm | |
| aterm :: Parser ATerm | |
| aterm = chainl1 aterm' (Mul <$ token "*") | |
| aterm' :: Parser ATerm | |
| aterm' = Atom <$> atom | |
| bexp :: Parser BExp | |
| bexp = chainr1 bexp' (And <$ token "&&") | |
| bexp' :: Parser BExp | |
| bexp' = BTerm <$> bterm | |
| bterm :: Parser BTerm | |
| bterm = Not <$ token "!" <*> bterm | |
| <|> BTom <$> btom | |
| btom :: Parser BTom | |
| btom = Lt <$> aexp <* token "<=" <*> aexp | |
| <|> Eq <$> aexp <* token "=" <*> aexp | |
| <|> BTrue <$ token "true" | |
| <|> BFalse <$ token "false" | |
| <|> BBrc <$ token "(" <*> bexp <* token ")" | |
| instance Pretty While where | |
| pretty (WhileLang stms) = pretty stms | |
| instance Pretty Stms where | |
| pretty (Semi xs ys) = pretty xs ++ "; " ++ pretty ys | |
| pretty (Stm stm) = pretty stm | |
| instance Pretty Stm where | |
| pretty (Skip) = "skip" | |
| pretty (Def var aexp) = pretty var ++ " := " ++ pretty aexp | |
| pretty (SBrc stms) = "(" ++ pretty stms ++ ")" | |
| pretty (If bexp x y) = "if " ++ pretty bexp ++ " then " ++ pretty x ++ " else " ++ pretty y | |
| pretty (While bexp stm) = "while " ++ pretty bexp ++ " do " ++ pretty stm | |
| instance Pretty AExp where | |
| pretty (Add x y) = pretty x ++ " + " ++ pretty y | |
| pretty (Sub x y) = pretty x ++ " + " ++ pretty y | |
| pretty (ATerm x) = pretty x | |
| instance Pretty ATerm where | |
| pretty (Mul x y) = pretty x ++ " * " ++ pretty y | |
| pretty (Atom x) = pretty x | |
| instance Pretty Atom where | |
| pretty (ANum x) = pretty x | |
| pretty (AVar x) = pretty x | |
| pretty (ABrc exp) = "( " ++ pretty exp ++ " )" | |
| instance Pretty Num where | |
| pretty (Num x) = show x | |
| instance Pretty Var where | |
| pretty (Var x) = x | |
| instance Pretty BExp where | |
| pretty (And x y) = pretty x ++ " && " ++ pretty y | |
| pretty (BTerm x) = pretty x | |
| instance Pretty BTerm where | |
| pretty (Not x) = "! " ++ pretty x | |
| pretty (BTom x) = pretty x | |
| instance Pretty BTom where | |
| pretty (Lt x y) = pretty x ++ " <= " ++ pretty y | |
| pretty (Eq x y) = pretty x ++ " = " ++ pretty y | |
| pretty (BTrue) = "true" | |
| pretty (BFalse) = "false" | |
| pretty (BBrc x) = "(" ++ pretty x ++ ")" | |
| -- debugging | |
| r :: String -> [(While, String)] | |
| r xs = parse lang xs | |
| cmpl :: String -> While | |
| cmpl x = fst $ r x !! 0 | |
| cf = do x <- readFile "./program" | |
| putStr $ show (cmpl x) ++ "\n" | |
| pf = do x <- readFile "./program" | |
| putStr $ ((pretty $ cmpl x) ++ "\n") | |
| -- | |
| (<<$$>>) :: (a -> b) -> Parser a -> Parser b | |
| (<<$$>>) f p = pure f <*> p | |
| -- id <$ px <*> py |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment