{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Main
-- Copyright   :  (c) Masahiro Sakai 2004,2009
-- License     :  BSD-style
-- 
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-----------------------------------------------------------------------------

module Main where

import CDT
import Exp
import qualified Statement
import qualified CPLSystem as Sys
import qualified AExp
import Type
import Typing (Typing(..))
import qualified Simp

import Data.Maybe
import Data.List
import Data.Char (isSpace)
import System.Environment
import System.Exit
import System.IO
import Control.Monad.State
import Control.Monad.Error
import System.Console.GetOpt
#if defined(USE_READLINE_PACKAGE)
import qualified System.Console.SimpleLineEditor as SLE
import Control.Exception (bracket)
#elif defined(USE_HASKELINE_PACKAGE)
import System.Console.Haskeline
#else
import Control.Exception (bracket)
#endif

----------------------------------------------------------------------------

type UIState = Sys.System

#ifdef USE_HASKELINE_PACKAGE
type UI a = StateT UIState (InputT IO) a
#else
type UI a = StateT UIState IO a
#endif

initialState :: UIState
initialState = Sys.emptySystem

----------------------------------------------------------------------------
--- Utility

shift :: String -> (String, String)
shift = break isSpace . dropWhile isSpace

strip :: String -> String
strip = reverse . f . reverse . f
    where f = dropWhile isSpace

indent :: Int -> String -> String
indent n = unlines . map (prefix++) . lines
    where prefix = replicate n ' '

showObjectInfo :: CDT.CDT -> String
showObjectInfo obj =
    t ++ showFunctNameWithVariance obj ++ "\n" ++
    "- natural transformations:\n" ++
    natsStr ++
    "- factorizer:\n" ++ factorizerInfoStr ++
    "- equations:\n" ++ indent 4 equations ++
    "- unconditioned: " ++ (if CDT.isUnconditioned obj then "yes" else "no") ++
    "\n" ++
    "- productive: (" ++ productiveStr ++ ")\n"
    where t = case CDT.objectType obj of
              LeftObject  -> "left object "
              RightObject -> "right object "
          natsStr = indent 4 $ concatMap f (CDT.nats obj)
              where f nat = CDT.natName nat ++ ": " ++
                            show (CDT.natType nat) ++ "\n"
          productiveStr = intercalate "," (map f [0 .. CDT.functArity obj - 1])
              where f n = if CDT.isProductiveIn obj n
                          then "yes"
                          else "no"
          factorizerInfoStr =
              indent 4 $
                  upper ++ "\n" ++
                  replicate (max (length upper) (length lower)) '-' ++ "\n" ++
                  lower ++ "\n"
              where upper = intercalate "  " $ zipWith f factArgs $ factParams obj
                        where f fact typ = show fact ++ ": " ++ show typ
                    lower =
                        show (Fact obj factArgs) ++ ": " ++
                        show (factDestType obj)
                    factArgs = map f (CDT.nats obj)
                        where f nat = Var ("f" ++ show (CDT.natIndex nat)) []
          equations = concat (map (++"\n") (eqs ++ [feq, ceq]))
              where eqs = zipWith g [(1::Int)..] (Statement.eqs obj)
                        where g n eq = "("++lr++"EQ" ++ show n ++ "): " ++
                                       show eq
                    feq = "("++lr++"FEQ): " ++ show (Statement.feq obj)
                    ceq = "("++lr++"CEQ): " ++ show (Statement.ceq obj)
                    lr = case CDT.objectType obj of
                         LeftObject  -> "L"
                         RightObject -> "R"

readLine :: String -> UI String
#if defined(USE_READLINE_PACKAGE)
readLine prompt = liftIO $ fmap (fromMaybe "") (SLE.getLineEdited prompt)
#elif defined(USE_HASKELINE_PACKAGE)
readLine prompt = fmap (fromMaybe "") (lift (getInputLine prompt))
#else
readLine prompt = liftIO $ putStr prompt >> getLine
#endif

----------------------------------------------------------------------------

type Command = String -> UI ()

commandTable :: [(String, Command)]
commandTable =
    [ ("show",  cmdShow)
    , ("edit",  cmdEdit)
    , ("simp",  cmdSimp)
    , ("let",   cmdLet)
    , ("load",  cmdLoad)
    , ("quit",  cmdQuit)
    , ("exit",  cmdQuit)
    , ("bye",   cmdQuit)
    , ("help",  cmdHelp)
    , ("set",   cmdSet)
    , ("reset", cmdReset)

    , ("left",  cmdLeft)
    , ("right", cmdRight)
    ]

dispatchCommand :: String -> UI ()
dispatchCommand l =
    case shift l of
        ([], _) -> return ()
        (cmdStr, arg) ->
            case lookup cmdStr commandTable of
            Just cmd -> cmd arg
            Nothing  -> liftIO $ ioError $ userError $  ("unknown command: " ++ l)

----------------------------------------------------------------------------

defineObject :: Command
defineObject src =
    do sys <- get
       obj <- Sys.parseCDT sys src
       sys' <- Sys.addCDT sys obj
       put sys'
       let lr = case CDT.objectType obj of
                     LeftObject  -> "left"
                     RightObject -> "right"
           msg = concat [lr, " object ", showFunctNameWithVariance obj, " is defined"]
       liftIO $ putStrLn $ msg

cmdLeft, cmdRight :: Command
cmdLeft  s = defineObject ("left " ++ s)
cmdRight s = defineObject ("right " ++ s)

cmdShow :: Command
cmdShow arg =
    case shift arg of
    ("object", arg') ->
        do sys <- get
           let name    = strip arg'
               objects = Sys.objects sys
           liftIO $ putStrLn $
                case find (\x -> CDT.functName x == name) objects of
                Just obj -> showObjectInfo obj
                Nothing  -> "unknown object: " ++ name
    ("aexp", arg') -> do -- XXX
      sys <- get
      case Sys.parseExp sys (strip arg') of
        Left err -> fail err
        Right (_, e :! t) -> liftIO $ do
          putStrLn $ show e
          putStrLn $ "    : " ++ show t
    _ -> do
      sys <- get
      case Sys.parseExp sys (strip arg) of
        Left err -> fail err
        Right (_, e :! t) -> liftIO $ do
          putStrLn $ show $ AExp.skelton e
          putStrLn $ "    : " ++ show t

cmdLet :: Command
cmdLet arg = do
  sys <- get
  case Sys.parseDef sys (strip arg) of
    Left err -> fail err
    Right def@(name, args, e, FType _ args' t) -> do
      sys' <- Sys.letExp sys def
      put sys'
      if null args
        then liftIO $ do
          putStrLn $ name ++ " = " ++ show (AExp.skelton e)
          putStrLn $ "    : " ++ show t
        else liftIO $ do
          let lhs = name ++ "(" ++ intercalate "," args ++ ")"
          putStrLn $ lhs ++ " = " ++ show (AExp.skelton e)
          let upper = intercalate "  " $ [p ++ ": " ++ show t | (p,t) <- zip args args']
              lower = lhs ++ ": " ++ show t
              s = upper ++ "\n" ++
                  replicate (max (length upper) (length lower)) '-' ++ "\n" ++
                  lower
          putStrLn $ s
          -- putStrLn $ "    : " ++ intercalate ", " (map show args') ++ " => " ++ show t

cmdSimp :: Command
cmdSimp arg =
  case shift arg of
    ("full", arg') ->
        doSimp True (strip arg')
    _ ->
        doSimp False (strip arg)
  where
    doSimp full str = do
      sys <- get
      unless (any isTerminalObject (Sys.objects sys))
             (fail "No terminal object is defined.")
      case Sys.parseExp sys str of
        Left err -> fail err
        Right (_, e :! t) -> do
          unless (AExp.isElement e) (fail "not a element")
          let traces = Sys.simp sys full (AExp.skelton e)
              loop ((step,(depth,exp,cexp)) : xs) = do
                let line = show step
                         ++ (if depth==0 then "" else "[" ++ show depth ++ "]")
                         ++ ":" ++ show (Simp.decompile exp) ++ "*" ++ show (Simp.decompile cexp)
                when (Sys.trace sys) $ liftIO $ putStrLn line
                if null xs
                  then do
                    let it = Simp.decompile cexp
                    liftIO $ putStrLn (show it)
                    liftIO $ putStrLn ("    : " ++ show t)
                    put sys{ Sys.lastExp = Just it }
                  else
                    loop xs
          loop (zip [(0::Int)..] traces)

cmdLoad :: Command
cmdLoad s =
    do h <- liftIO $ openFile filename ReadMode
       contents <- liftIO $ hGetContents h
       let src  = unlines (map removeComment (lines contents))
           cmds = split src
       mapM_ (\x -> do liftIO $ (putStr . unlines . map ("> "++) . lines $ x)
                       dispatchCommand x)
             cmds
    where filename = -- FIXME
              let s' = strip s in
                  case s' of
                  '"':_ -> read s'
                  _     -> s'
          removeComment []      = []
          removeComment ('#':_) = []
          removeComment (x:xs)  = x : removeComment xs
          split :: String -> [String]
          split s = map (strip . reverse) (f s [])
              where f (';':xs) tmp = tmp : (f xs [])
                    f (x:xs) tmp   = f xs (x:tmp)
                    f [] tmp       = [tmp]

cmdEdit :: Command
cmdEdit _ =
    do s <- editLoop
       dispatchCommand s
    where editLoop =
              do l <- readLine "| "
                 case dropWhile isSpace (reverse l) of
                     ';':s -> return (reverse s)
                     _ -> do s <- editLoop
                             return $ l ++ "\n" ++ s

cmdQuit :: Command
cmdQuit _ = liftIO $ exitWith ExitSuccess

cmdHelp :: Command
cmdHelp _ = liftIO $ mapM_ putStrLn l
    where l = [ "  exit                        exit the interpreter"
              , "  quit                        ditto"
              , "  bye                         ditto"
              , "  edit                        enter editing mode"
              , "  simp [full] <exp>           evaluate expression"
              , "  show <exp>                  print type of expression"
              , "  show object <functor>       print information of functor"
              , "  load <filename>             load from file"
              , "  set trace [on|off]          enable/disable trace"
              , "  reset                       remove all definitions"
              ]

cmdSet :: Command
cmdSet arg =
    case shift arg of
    (flag, a) ->
        case shift a of
        ([], _) ->
            case flag of
            "trace" ->
                do sys <- get
                   liftIO $ putStrLn $
                            "trace=" ++ (if Sys.trace sys then "on" else "off")
            _ ->
                liftIO $ putStrLn $ "unknown flag:" ++ flag
        (value, _) ->
            case flag of
            "trace" ->
                case value of
                "on"  ->
                    do sys <- get
                       put (sys{ Sys.trace = True })
                "off" ->
                    do sys <- get
                       put (sys{ Sys.trace = False })
                _ ->
                    liftIO $ putStrLn ("unknown value:" ++ value)
            _ ->
                liftIO $ putStrLn ("unknown flag:" ++ flag)

cmdReset :: Command
cmdReset _ = put initialState

----------------------------------------------------------------------------

data Flag
    = Help
    | Version
    | Interactive
    -- | Load String
    | Trace String
    deriving Eq

options :: [OptDescr Flag]
options =
    [ Option ['h'] ["help"]    (NoArg Help)            "show help"
    , Option ['v'] ["version"] (NoArg Version)         "show version number"
    , Option ['i'] ["interactive"] (NoArg Interactive) "force interactive mode"
    -- , Option ['l'] ["load"]    (ReqArg Load "FILE") "load FILE"
    , Option ['t'] ["trace"]    (OptArg (Trace . fromMaybe "on") "[on|off]")
             "enable/disable trace"
    ]

main :: IO ()
#if defined(USE_READLINE_PACKAGE)
main = bracket SLE.initialise (const SLE.restore) (const main_)
#elif defined(USE_HASKELINE_PACKAGE)
main = runInputT defaultSettings main_
#else
main = 
    do bracket (do x <- hGetBuffering stdout
                   hSetBuffering stdout NoBuffering
                   return x)
               (hSetBuffering stdout)
               (const main_)
#endif

main_ =
    do args <- liftIO $ getArgs
       case getOpt Permute options args of
         (o,_,[])
           | Help `elem` o    -> liftIO $ putStrLn (usageInfo header options)
           | Version `elem` o -> liftIO $ putStrLn versionStr
         (o,n,[]) ->
             do liftIO $ putStr banner
                evalStateT (do mapM_ processOpt o
                               mapM_ cmdLoad n
                               if null n || Interactive `elem` o
                                   then mainLoop
                                   else return ())
                           initialState
         (_,_,errs) ->
             liftIO $ ioError $ userError $ concat errs ++ usageInfo header options

version :: [Int]
version = [0,0,6]

versionStr :: String
versionStr = intercalate "." $ map show $ version

header :: String
header = "Usage: cpl [OPTION...] files..."

banner :: String
banner =
    "Categorical Programming Language (Haskell version)\n" ++
    "version " ++ versionStr ++ "\n" ++
    "\n" ++
    "Type help for help\n" ++
    "\n"

processOpt :: Flag -> UI ()
processOpt (Trace s) =
    do sys <- get
       val <- case s of
              "on"  -> return True
              "off" -> return False
              _     -> fail "invalid option"
       put sys{ Sys.trace = val }
       return ()
processOpt _ = return ()

mainLoop :: UI ()
mainLoop = do
  l <- readLine "cpl> "
#if defined(USE_HASKELINE_PACKAGE)
  handle h (dispatchCommand l)
#else
  dispatchCommand l `catchError`  h
#endif
  mainLoop
  where
    h :: IOError -> UI ()
    h = liftIO . putStrLn . show

----------------------------------------------------------------------------