Parser.hs

{-# OPTIONS_GHC -Wall #-}

module Theseus.Parser where

import Theseus.Lexer
import Theseus.Syntax

import Data.List as List
import Data.Char as Char

import Text.Parsec hiding (label, labels, parse)
import Text.Parsec.Expr
import Text.Parsec.Token hiding (reserved, identifier, parens, reservedOp, symbol)

progParser :: TParser Prog
progParser = do
  whiteSpace lexer 
  defs <- many defParser 
  eof
  pure defs

defParser :: TParser Def
defParser = do 
  t    <- reserved "data" >> identifier
  _    <- symbol "="
  args <- sepBy (do
    ctor <- identifier
    typ  <- option One typParser
    pure (ctor, typ))
      (symbol "|")
  pure (DataTyp t (List.sort args))
  -- <|> do
  --reserved "eval"
  --func <- funcParser
  --v <- valParser
  --pure (Eval func v)
  -- <|> do
  -- reserved "import"
  -- modname <- uppercaseParse "module name"
  -- pure (Import modname)
  <|> do
  fname <- try $ do 
    fname <- identifier
    reserved ":"
    pure fname
  {- fparams <- many $ try $ do
    arg  <- identifier
    _    <- symbol "FOO"
    ityp <- itypParser
    _    <- symbol "BAR"
    pure (arg, ityp)
  ityp <- itypParser
  clauses <- many $ do
    _ <- symbol "|"
    p1 <- valParserWithLabel
    _ <- symbol "="
    p2 <- valParserWithLabel
    pure (Clause p1 p2)
  labels <- option [] $ do
    reserved "where"
    many1 $ do
      label <- identifier
      _ <- symbol ":"
      typ <- typParser
      pure (label, typ)
  -}
  --pure (Iso fname fparams ityp labels clauses)
  pure (Iso fname emptyFormals emptyITyp emptyLName [emptyClause])

funcParser :: TParser Func 
funcParser = do
  name <- lowercaseParse "name"
  args <- many $ do
    _ <- symbol "~"
    label <- lowercaseParse "label"
    opt <- option Nothing $ do
      _ <- symbol ":"
      arg <- simpleParser
      pure (Just arg)
    pure (label, opt)
  pure (Func name args)
  where
    simpleParser :: TParser Func
    simpleParser = do
      name <- lowercaseParse "name"
      pure (Func name [])
      <|>
      (parens funcParser)

typParser :: TParser Typ 
typParser = buildExpressionParser typTable simpleTypParser
  where simpleTypParser = 
            (symbol "0" >> pure Zero) 
            <|> 
            (symbol "1" >> pure One) 
            <|> 
            (do t <- identifier
                pure (TName t))
            <|>
            (parens typParser)
        typTable = 
            [[Prefix (reservedOp "-" >> pure Neg)],
             [Infix  (reservedOp "*" >> pure Times) AssocLeft],
             [Infix  (reservedOp "+" >> pure Plus) AssocLeft]]

valParser :: TParser PVal
valParser = buildExpressionParser valTable simpleValParser
    where 
      simpleValParser = 
          (reservedOp "()" >> pure Unit)
          <|>
          (try (do fname <- funcParser; 
                   val <- simpleValParser
                   pure (App fname val)))
          <|>
          (do name <- lowercaseParse "variable"
              pure (Var name)) 
          <|>
          (do name <- uppercaseParse "constructor";
              val <- option Unit simpleValParser
              pure (Constr name val))
          <|>
          (parens valParser)
      valTable = 
          [[Prefix (do _ <- reserved "inL"; pure LeftE),
            Prefix (do _ <- reserved "inR"; pure RightE)],
           [Infix (reservedOp "," >> pure Pair) AssocLeft]]

valParserWithLabel :: TParser (Maybe LName, PVal)
valParserWithLabel = do 
  do label <- option Nothing 
              (try (do l <- identifier
                       _ <- symbol "$"
                       pure (Just l)))
     val <- valParser 
     pure (label, val)

itypParser :: TParser ITyp
itypParser = try parse 
             <|> parens parse
    where 
      parse = typParser >>= \t1 -> 
              symbol "=" >>  -- CHANGED
              typParser >>= \t2 -> 
              pure (ITyp t1 t2)


startsWithUpper :: String -> Bool
startsWithUpper [] = False 
startsWithUpper s = Char.isUpper (s !! 0) 

uppercaseParse :: String -> TParser String
uppercaseParse msg = try (do name <- identifier
                             if startsWithUpper name
                             then pure name
                             else fail msg)

lowercaseParse :: String -> TParser String
lowercaseParse msg = try (do name <- identifier
                             if startsWithUpper name 
                             then fail msg
                             else pure name)