haspl.hs

-- ghci haspl.hs
-- do a <- readFile "./kompilator/tests/25.spl"; parseTest splprog a
import Control.Monad (void)
import Data.Void
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Expr hiding (Operator)
import Data.List
import qualified Text.Megaparsec.Char.Lexer as L

data Name = SPLID String
instance Show Name where
  show (SPLID n) = n
data FieldKind = HD | TL | FST | SND
data Type = SPLInt | SPLBool | SPLChar Char | SPLPair Type Type | SPLList Type | SPLid Name
instance (Show Type) where
  show SPLInt = "Int"
  show SPLBool = "Bool"
  show (SPLChar c) = [c]
  show (SPLPair a b) = "(" <> (show a) <> ", " <> (show b) <> ")"
  show (SPLList a) = "[" <> (show a) <> "]"

data Value = VInt Int | VBool Bool | VPair (Value, Value) | VList [Value]
  deriving (Show)
data Stmt = IfStmt Expression [Stmt] (Maybe [Stmt])
          | WhileStmt Expression [Stmt]
          | ReturnStmt (Maybe Expression)
          | PrintStmt Expression
          | AssStmt Name Expression
          | FunCallStmt Name [Expression]
          | VarDecStmt [VarDec']
indent str = unlines $ ("\t"<>) <$> lines str
showbody b = "{\n" <> (indent $ unlines (show <$> b)) <> "}"
instance (Show Stmt) where
  show (IfStmt e body (Just elseb)) = "if (" <> show e <> ") " <> showbody body <> " else " <> showbody elseb
  show (IfStmt e body Nothing)="if (" <> show e <> ") " <> showbody body
  show (WhileStmt e body)    = "while (" <> show e <> ") " <> showbody body
  show (ReturnStmt (Just e)) = "return " <> show e <> ";"
  show (PrintStmt e) = "print " <> show e <> ";"
  show (ReturnStmt Nothing)  = "return;"
  show (AssStmt n e)         = show n <> " = " <> show e;
  show (FunCallStmt n e)     = show n <> "(" <> show e <> ")"
  show (VarDecStmt v)        = unwords (show <$> v)
data Expression -- = FieldExp Name Field
                = FunCallExp Name [Expression]
                | IDExp Name
                | IntExp Int
                | CharExp Char
                | BoolExp Bool
                | PairExp Expression Expression
                | ParenExp Expression
                | EmptyListExp
                | BinaryExpression Operator Expression Expression
                | UnaryOperator Operator Expression
instance Show Expression where
  show (FunCallExp n arg) = show n <> "(" <> intercalate ", " (show <$> arg) <> ")"
  show (IntExp i) = show i
  show (BinaryExpression op a b) = "(" <> show a <> " `" <> show op <> "` " <> show b <> ")"
  show (IDExp n) = show n
  show (BoolExp b) = show b
  show (PairExp a b) = "(" <> show a <> ", " <> show b <> ")"
  show (ParenExp p) = "(" <> show p <> ")"
  show EmptyListExp = "[]"
data VarDec' = VarDec' Type Name Expression
instance (Show VarDec') where
  show (VarDec' t n e) = show t <> " " <> show n <> " = " <> show e <> ";"
data Declaration = VariableDeclaration VarDec'
                 | FunctionDeclaration (Maybe Type) Name [(Type, Name)] [Stmt]
instance Show Declaration where
  show (VariableDeclaration v) = show v
  show (FunctionDeclaration t n arg body) =
    (maybe "Void" show t) <> "\n" <> show n <> "(" <> intercalate ", " (showarg <$> arg) <> ") " <> showbody body <> "\n"
    where showarg (t,n) = show t <> " " <> show n
data Operator = Equal | Unequal | LT | LE | GT | GE | And | Or | Cons | Plus | Minus | Mult | Div | Mod | Neg | UnMin deriving (Show)
data SPL = SPL [Declaration]
instance Show SPL where
  show (SPL s) = unlines (show <$> s)
type Parser = Parsec Void String
main :: IO ()
main = return ()

space' = L.space space1 (L.skipLineComment "//") (L.skipBlockComment "/*" "*/")
symbol = L.symbol space'
type' :: Parser Type
type' =  SPLInt <$ symbol "Int"
     <|> SPLBool <$ symbol "Bool"
     <|> SPLChar <$> letterChar <* space'
     <|> SPLPair <$> (symbol "(" *> type' <* symbol ",") <*> (type' <* symbol ")")
     <|> SPLList <$> (symbol "[" *> type' <* symbol "]")
  
term :: Parser Expression
term = IntExp <$> (L.signed space' L.decimal) <* space' -- todo: also parses '+10'
    <|> BoolExp True <$ symbol "True"
    <|> BoolExp False <$ symbol "False"
    <|> try (FunCallExp <$> (name <* symbol "(") <*> (expr `sepBy` symbol ",") <* symbol ")")
    <|> try (PairExp <$> (symbol "(" *> expr <* symbol ",") <*> expr <* symbol ")")
    <|> ParenExp <$> (symbol "(" *> expr <* symbol ")")
    <|> IDExp <$> name
    <|> EmptyListExp <$ (symbol "[" >> symbol "]")

expr :: Parser Expression
expr = makeExprParser term table <?> "expression"
table = [ [
            InfixL (BinaryExpression Plus <$ symbol "+"),
            InfixL (BinaryExpression Minus <$ symbol "-"),
            InfixL (BinaryExpression Main.Div <$ symbol "/"),
            InfixL (BinaryExpression Mod <$ symbol "%") ],
          [
            InfixL (BinaryExpression Main.GE <$ symbol ">="),
            InfixL (BinaryExpression Main.GT <$ symbol ">"),
            InfixL (BinaryExpression Main.LE <$ symbol "<="),
            InfixL (BinaryExpression Main.LT <$ symbol "<"),
            InfixL (BinaryExpression Equal <$ symbol "=="),
            InfixL (BinaryExpression Unequal <$ symbol "!="),
            InfixR (BinaryExpression Cons <$ symbol ":")
          ], [
            InfixL (BinaryExpression And <$ symbol "&&"),
            InfixL (BinaryExpression Or <$ symbol "||")
          ]];
  
name :: Parser Name
name = SPLID <$> ((:) <$> letterChar <*> many (alphaNumChar <|> char '_')) <* space'
-- surround :: String -> String -> m a -> m a
surround a b = between (symbol a) (symbol b) 
stmt :: Parser Stmt
stmt = (symbol "return" >> 
        ReturnStmt <$> (optional expr <* symbol ";"))
  <|> (symbol "print" >>
        PrintStmt <$> expr <* symbol ";")
  <|> (symbol "if" >> 
        IfStmt <$> surround "(" ")" expr <*> block <*> (optional $ symbol "else" >> block))
  <|> (symbol "while" >>
       WhileStmt <$> surround "(" ")" expr <*> block)
  <|> try (FunCallStmt <$> (name <* symbol "(") <*> (expr `sepBy` symbol ",") <* symbol ");")
  <|> try (AssStmt <$> (name <* (symbol "=")) <*> expr <* symbol ";")
  <|> VarDecStmt <$> pure <$> vardec
  where block = (surround "{" "}" (many stmt) <|> (pure <$> stmt))
vardec :: Parser VarDec'
vardec = VarDec' <$> type' <*> (name) <*> (symbol "=" *> expr <* symbol ";")
decl :: Parser Declaration
decl =
  (try 
    (FunctionDeclaration
    <$> (Nothing <$ symbol "Void" <|> (Just <$> type'))
    <*> name
    <*> (surround "(" ")" $ ((,) <$> type' <*> name) `sepBy` symbol ",")
    <*> (surround "{" "}" $ many stmt)))
  <|> (VariableDeclaration <$> vardec)

evalExp :: Expression -> Value
evalExp (IntExp i)    = VInt i
evalExp (BoolExp b)   = VBool b
evalExp (PairExp a b) = VPair (evalExp a, evalExp b)
evalExp EmptyListExp  = VList []
evalExp (IDExp i)     = error "need more monad magic"
evalExp (ParenExp p)  = evalExp p
evalExp (BinaryExpression Plus a b) =
  let (VInt an) = evalExp a
      (VInt bn) = evalExp b
  in VInt $ an + bn

splprog :: Parser SPL
splprog = SPL <$> (space' >> many decl)