{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}
module PTS.Parser ( parseStmt, parseStmts, parseTerm ) where

import Prelude hiding (abs, pi, elem, notElem, const)

import System.IO

import Control.Applicative hiding (many, Const)
import Control.Monad

import Data.Eq
import Data.Either
import Data.Foldable
import Data.Char

import Text.ParserCombinators.Parsec hiding ((<|>))
import qualified Text.ParserCombinators.Parsec as Parsec

import Tools.Instances
import Tools.Errors.Class

import Parametric.Parser
import Parametric.Parser.Error
import Parametric.Error

import PTS.AST

     -----------------
    -- PTS PARSER --
     ----------------- 

natop n f x = NatOp n f <$> (keyword n *> x) <*> (x <?> "second argument of '" ++ n ++ "'")

expr constant = term simple rec Pos "expression" where
  simple = withPos Pos $ asum 
    [ parens (expr constant)
    , abs Lam lambda (ident constant) colon1 (expr constant) dot (expr constant)
    , abs Pi  pi     (ident constant) colon1 (expr constant) dot (expr constant)
    , IfZero <$> (keyword "if0" *> expr constant) 
             <*> (keyword "then" *> expr constant) 
             <*> (keyword "else" *> expr constant)
    , natop "add" (+) simple
    , natop "sub" (-) simple
    , natop "mul" (*) simple
    , natop "div" div simple
    , Const <$> const constant
    , var Var (ident constant) 
    , Nat <$> number ]
    
  rec = asum
    [ app App simple
    , arr (\a b -> Pi (freshvar b "_") a b) arrow (expr constant)]

stmt constant = asum
  [ try (Bind <$> (ident constant) <* assign) <*> expr constant
  , Term <$> expr constant]

stmts constant = stmt constant `endBy` semi

     ---------
    -- LEXER --
     ---------

keywords = ["lambda", "Pi", "if0", "then", "else", "->", "add", "mul", "sub", "div"]

identChar x = not (isSpace x) && x `notElem` ".:=;/()"

ident constant = lexem (do name <- many1 (satisfy identChar) 
                           when (name `elem` keywords) $
                             unexpected ("keyword " ++ name)
                             
                           when (Prelude.all (`elem` ['0'..'9']) name) $
                             unexpected ("numeric literal " ++ name)
                             
                           case constant name of
                             Just _ -> unexpected ("constant " ++ name)
                             Nothing -> return name)
                   <?> "variable name"

number = read <$> lexem (many1 (satisfy isDigit) <* notFollowedBy (satisfy identChar))

const constant = lexem (do name <- many1 (satisfy identChar) 
                           when (name `elem` keywords) $
                             unexpected ("keyword " ++ name)
                             
                           when (Prelude.all (`elem` ['0'..'9']) name) $
                             unexpected ("numeric literal " ++ name)
                             
                           case constant name of
                             Just x -> return x
                             Nothing -> unexpected ("variable name " ++ name))
                   <?> "constant"

keyword s  = lexem (string s <* notFollowedBy (satisfy identChar))

comment = string "/*" <* manyTill anyChar (try (string "*/"))

skipSpace = skipMany ((space *> pure () <|> comment *> pure ()) <?> "")
lexem p = try p <* skipSpace 

dot    = lexem (char '.')
colon1 = lexem (char ':')
lambda = keyword "lambda"
pi     = keyword "Pi"
if0    = lexem (keyword "if0")
assign = lexem (char '=')
semi   = lexem (char ';')
arrow  = lexem (string "->")

parens p   = lparen *> p <* rparen

lparen = lexem(char '(')
rparen = lexem(char ')')

     ----------------------
    -- RUNNING the PARSER --
     ----------------------

parseInternal parser constant file text 
  = case parse (skipSpace *> parser constant <* eof) file text of
      Left e -> throwError . pure . formatError text $ e 
      Right r -> return r 

parseStmt = parseInternal stmt

parseStmts = parseInternal stmts
parseTerm = parseInternal expr
