{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}
module Main where

import System.Environment

import Control.Monad

import Control.Monad.Trans

import Tools.Errors (runErrorsT, catchError, MonadErrors (..))
import Parametric.Error
import Parametric.Pretty hiding (when)

import PTS.AST
import PTS.Parser
import PTS.Core
import PTS.Debug

-- compile time OPTIONS
-- TODO: change to command line options
-- see PTS.Debug for more debug options
columns = 80
showFullTerms = ShowFullTerms `elem` options

infixl 2 >>>
(>>>) = flip (.)

main = runErrorsT $  main' `catchError` \e -> liftIO $ putStrLn (showErrors e)

main' = do
  args <- liftIO getArgs 
  when (length args == 0) (fail "no pts instance selected")
  let (name : rest) = args
  
  case name of
    "simplytyped" -> processFiles (simplytyped, simplytypedConstants) rest
    "fomega" -> processFiles (fomega, fomegaConstants) rest 
    "coc" ->  processFiles (coc, cocConstants) rest
    "lambdastar" -> processFiles (lambdastar, lambdastarConstants) rest
    "\\*" -> processFiles (lambdastar, lambdastarConstants) rest
    "fomegastar" -> processFiles (fomegastar, fomegastarConstants) rest
    "fomegaomega" -> processFiles (fomegaomega, fomegaomegaConstants) rest
    name -> fail $ "unknown pure type system instance " ++ name

processFiles pts files 
  = mapM (processFile pts) files >>= foldM_ (processStmts pts) [] 
  
processFile pts file = do
  text <- liftIO (readFile file)
  stmts <- parseStmts (snd pts) file text
  return (lines text, stmts)

processStmts pts env (text, stmts) 
  = annotateCode text $ foldM (processStmt pts) env stmts

processStmt pts env (Term t) = recover env $ do
  output (text "")
  output (text "process expression")
  output (nest 2 (sep [text "original term", nest 2 (pretty 0 t)])) 
  t <- prepareTerm pts env t
  when showFullTerms $ output (nest 2 (sep [text "full term", nest 2 (pretty 0 t)])) 
  q <- typecheck (fst pts) 0 [] t
  output (nest 2 (sep [text "type", nest 2 (pretty 0 q)])) 
  let x = eval t
  output (nest 2 (sep [text "value", nest 2 (pretty 0 x)])) 
  return env
  
processStmt pts env (Bind n t) = recover env $ do
  output (text "")
  output (text "process binding of" <+> text n)
  output (nest 2 (sep [text "original term", nest 2 (pretty 0 t)])) 
  t <- prepareTerm pts env t
  when showFullTerms $ output (nest 2 (sep [text "full term", nest 2 (pretty 0 t)])) 
  q <- typecheck (fst pts) 0 [] t
  output (nest 2 (sep [text "type", nest 2 (pretty 0 q)])) 
  return ((n, t) : env)

prepareTerm pts env t = do
  let t' = foldr substGlobal t env
  return t' -- freevars2constants consts consts t' 

substGlobal (n, e) t = subst t n e

output doc = liftIO (putStrLn (multiLine columns doc))
