{-# LANGUAGE OverloadedStrings #-}

module Funcons.Tools (
    -- * Creating standalone interpreters.

    -- $moduledoc
    mkMain, mkMainWithLibrary, mkMainWithLibraryEntities,
    mkMainWithLibraryTypes, mkMainWithLibraryEntitiesTypes,
    -- * Creating embedded interpreters.
    run, runWithExtensions,
    -- * Utility functions for interpreter extensions. 
    -- ** Funcon libraries.
    FunconLibrary, libEmpty, libUnion, libUnions, libFromList,
    -- ** Type environments.
    TypeEnv, DataTypeMembers(..), DataTypeAlt(..), TypeParam, 
        emptyTypeEnv, typeEnvUnion, typeEnvUnions, typeEnvFromList,
    -- ** Entity declarations 
    EntityDefaults, EntityDefault(..), noEntityDefaults,
    ) where

import Funcons.EDSL (library)
import Funcons.RunOptions
import Funcons.Types
import Funcons.Entities
import Funcons.MSOS
import Funcons.Core.Library
import Funcons.Core.Manual
import Funcons.Printer

import System.Environment (getArgs)

import Data.Text (unpack)
import Data.List ((\\), intercalate)
import qualified Data.Map as M
import Control.Monad (forM_, when, unless)

-- | The empty collection of entity defaults.
noEntityDefaults :: [EntityDefault]
noEntityDefaults = []

-- | Creates a /main/ function for the default interpreter (no extension).
-- The executable made from this /main/ function receives command line
-- argumenst as explained above ("Funcons.Tools"). 
mkMain :: IO ()
mkMain = mkMainWithLibrary libEmpty 

-- | Creates a /main/ function for the interpreter obtained by extending
-- the default library with the funcons in the 'FunconLibrary' argument.
mkMainWithLibrary :: FunconLibrary -> IO() 
mkMainWithLibrary lib = mkMainWithLibraryEntities lib [] 

-- | Creates a /main/ function for the interpreter obtained by extending
-- the main interpreter  with the funcons in the 'FunconLibrary' argument
-- and with default values for entities defined in the 'EntityDefaults' 
-- argument.
mkMainWithLibraryEntities :: FunconLibrary -> EntityDefaults -> IO ()
mkMainWithLibraryEntities lib ents = 
    mkMainWithLibraryEntitiesTypes lib ents emptyTypeEnv

-- | Creates a /main/ function for the interpreter obtained by extending
-- the main interpreter with the funcons in the 'FunconLibrary' argument
-- and with a 'TypeEnv' mapping datatypes to their constructors and
-- type arguments.
mkMainWithLibraryTypes :: FunconLibrary -> TypeEnv -> IO ()
mkMainWithLibraryTypes lib tys = mkMainWithLibraryEntitiesTypes lib [] tys

-- | Creates a /main/ function for the interpreter obtained by extending
-- the main interpreter with funcons, 'EntityDefaults' and a 'TypeEnv'. 
mkMainWithLibraryEntitiesTypes :: FunconLibrary -> EntityDefaults -> TypeEnv -> IO ()
mkMainWithLibraryEntitiesTypes lib defaults tyenv = do   
    args <- getArgs
    case args of
        []      -> go0
        _       -> go2 args
 where  go0 = putStrLn "Please provide me with an .fct file"
        go2 args = runWithExtensions lib defaults tyenv args Nothing 

-- | Same as 'run', except receiving additional interpreter extensions as arguments.
-- Useful when a translation to 'Funcons' has been implemented in Haskell as
-- well as 'Funcons', entities or datatypes specific to the object language.
runWithExtensions :: 
    FunconLibrary -> EntityDefaults -> TypeEnv -> [String] -> Maybe Funcons -> IO ()
runWithExtensions lib defaults tyenv = 
    emulate full_lib full_defaults full_tyenv 
 where
        full_lib = libUnions [lib
                             ,Funcons.EDSL.library
                             ,Funcons.Core.Manual.library
                             ,Funcons.Core.Library.funcons]
        full_defaults = concat [defaults, Funcons.Core.Library.entities]
        full_tyenv = typeEnvUnions [tyenv, Funcons.Core.Library.types]

-- | 
-- Creates a main function by passing in a list of command line arguments 
-- and an optional initial 'Funcons' to execute. The 'Funcons' argument is optional
-- as one of the command line arguments may refer to an .fct file or .config
-- file that specifies an initial 'Funcons' term.
-- Useful when a translation to 'Funcons' has been implemented in Haskell.
run :: [String] -> Maybe Funcons -> IO ()
run = runWithExtensions libEmpty [] emptyTypeEnv 

------------------------------------------------------------------------------
--- running programs 
emulate lib defaults tyenv args mf0 = do
    (opts, unknown_opts) <- run_options args
    forM_ unknown_opts $ \arg -> do
        putStrLn ("unknown option: " ++ arg)
    case interactive_mode opts of 
        True    -> emulate' (fread (string_inputs opts) :: Name -> IO Values) lib defaults tyenv opts mf0
        False   -> emulate' (fread (string_inputs opts) :: Name -> SimIO Values) lib defaults tyenv opts mf0

emulate' :: Interactive m => (Name -> m Values) -> 
            FunconLibrary -> EntityDefaults -> TypeEnv -> RunOptions -> Maybe Funcons -> IO ()
emulate' reader lib defaults tyenv opts mf0 = do 
    -- the initial funcon term must be either given from a .fct file (Maybe Funcons)
    -- or specified in a configuration file
    let f0 = maybe (funcon_term opts) id mf0  
        msos_ctxt = MSOSReader (RewriteReader lib tyenv opts f0 f0) emptyINH
    -- run the Interactive monad, returning in the evaluation results + entity values.
    -- if in --interactive-mode the Interactive monad will be IO 
    --  and all the desired output will already have been printed to the screen
    ((e_exc_f, mut, wr), rem_ins) <- 
        fexec (runMSOS (setEntityDefaults defaults (stepTrans opts 0 f0))
                msos_ctxt (emptyMSOSState {inp_es = inputs})) (inputValues opts)
    -- if not in --interactive-mode then print additional information based on flags
    unless (interactive_mode opts) 
        (withResults defaults msos_ctxt e_exc_f mut wr rem_ins)
 where inputs = foldr op M.empty defaults
                where   op (DefInput nm) = M.insert nm ([], Just (reader nm))
                        op _             = id

withResults defaults msos_ctxt e_exc_f msos_state wr rem_ins
        | show_tests opts = 
            case e_exc_f of
             Left ie -> putStrLn (showIException ie)
             Right f -> printTestResults f defaults msos_ctxt msos_state wr rem_ins
        | otherwise = do
    unless (show_output_only opts) $ do
        printCounts 
        case e_exc_f of 
            Left ie -> putStrLn (showIException ie)
            Right f -> printResult f
        printMutable
        printControl
        printInputOutput rem_ins (hide_input opts)
    printOutput
 where
    muts = mut_entities msos_state 
    opts = run_opts (ereader msos_ctxt)
    printResult f = when (show_result opts) $ do
                        putStrLn "Result:"
                        putStrLn (ppFuncons opts f)
                        putStrLn ""

    printCounts = when (show_counts opts) 
                    (putStrLn $ show (counters (ewriter wr)))

    printMutable = forM_ toShow display
     where toShow = show_mutable opts
           display name = case M.lookup name muts of
                            Nothing -> return ()
                            Just v ->  putStrLn ("Mutable Entity: " ++ unpack name) >>
                                       putStrLn (displayValue v) >> putStrLn ""

    printControl = forM_ (M.keys ctrl \\ toHide) display
     where ctrl = ctrl_entities wr
           toHide = hide_control opts
           display name = case M.lookup name ctrl of
                            Just (Just v) -> do
                                putStrLn ("Control Entity: " ++ unpack name) 
                                putStrLn (displayValue v) >> putStrLn ""
                            _             -> return ()

    printOutput = forM_ (M.keys out \\ toHide) display
     where out = out_entities wr
           display name = do
                    unless (show_output_only opts) 
                        (putStrLn ("Output Entity: " ++ unpack name))
                    case all isString_ vs && pp_string_outputs opts of
                        True    -> mapM_ (\(String s) -> putStr s) vs
                        False   -> putStrLn (displayValue (List vs))
                    unless (show_output_only opts) (putStrLn "")
            where vs = out M.! name
           toHide = hide_output opts


    printInputOutput ios toHide = forM_ (M.keys ios \\ toHide) display
     where display name = unless (null vs) $ do 
                            putStrLn ("Output Entity: " ++ unpack name)
                            putStrLn (displayValue (List vs))
                            putStrLn ""
            where vs = ios M.! name

    displayValue (Map m) = intercalate "\n" 
                                   [ displayValue key ++ " |-> " ++ displayValue val 
                                   | (key, val) <- M.assocs m ]
    displayValue (ADTVal "variable" [Atom a, ComputationType (Type t)]) = 
        "variable(" ++ displayValue (Atom a) ++ ", " ++ ppTypes opts t ++ ")"
    displayValue (Atom a) = "@" ++ a
    displayValue (List vs) | all isString_ vs = concatMap displayValue vs
    displayValue (ADTVal con vs) = unpack con ++"("++ intercalate "," (map displayValue vs)++")"
    displayValue val = ppValues opts val

printTestResults :: Funcons -> EntityDefaults -> MSOSReader -> 
                        MSOSState m -> MSOSWriter -> InputValues -> IO ()
printTestResults f defaults msos_ctxt msos_state wr rem_ins = do
        forM_ (M.keys opts) printNotExists
        when (M.member "result-term" opts) $
            unless (result_term == f) (reportError "result-term" result_term f)
        printMutable
        printControl
        printInputOutput out
        printInputOutput rem_ins

    where   eval_ctxt = ereader msos_ctxt
            muts = mut_entities msos_state
            eval_state = estate msos_state
            localEval name term = case runRewrite (rewriteFuncons term) eval_ctxt eval_state
                of  (Left ie,_,_) -> error ("internal exception in " ++ unpack name 
                                    ++ " evaluation:\n" ++ showIException ie)
                    (Right (ValTerm v),_,_) -> v
                    (Right _,_,_) ->
                         error ("evaluation of " ++ unpack name ++ " requires step")
    
            mLocalEval term = case runRewrite(rewriteFuncons term) eval_ctxt eval_state of
                (Right (ValTerm v),_,_) -> Just v
                _                         -> Nothing

            result_term = case recursiveFunconValue rf of
                Nothing -> case mLocalEval rf of
                                Nothing -> rf
                                Just v  -> FValue v
                Just v  -> FValue v
             where rf = (opts M.! "result-term")
            opts = expected_outcomes (run_opts eval_ctxt)

            reportError name expected actual = do
                putStrLn ("expected " ++ unpack name ++ ": " ++ show expected)
                putStrLn ("actual   " ++ unpack name ++ ": " ++ show actual)

            printNotExists "result-term" = return ()
            printNotExists name = 
                case (M.lookup name muts, M.lookup name out
                     ,M.lookup name ctrl, M.lookup name rem_ins) of
                    (Nothing, Nothing, Nothing, Nothing) -> 
                        putStrLn ("unknown entity: " ++ unpack name)
                    _ -> return ()
        
            printMutable = forM_ (M.assocs muts) (uncurry display)
             where display name val = case M.lookup name opts of
                        Nothing -> return ()
                        Just expected -> unless (localEval name expected == val) 
                                            (reportError name expected val)

            -- set default values of output and control entities
            ctrl = foldr op (ctrl_entities wr) defaults
             where  op (DefControl name) ctrl 
                        | not (M.member name ctrl) = M.insert name Nothing ctrl
                    op _ ctrl = ctrl

            out = foldr op (out_entities wr) defaults
             where  op (DefOutput name) out 
                        | not (M.member name out) = M.insert name [] out
                    op _ out = out

            -- TODO this does not test the case that a control signal is expected 
            --      according to the test, but not present.
            printControl = forM_ (M.assocs ctrl) (uncurry display)
             where  -- test whether control signal is expected when there is none
                    -- shows expected signal 
                    display name Nothing = case M.lookup name opts of 
                        Nothing -> return ()
                        Just val -> putStrLn ("expected "++unpack name++": "
                                        ++ show (localEval name val))
                    -- test whether control signal is expected when there is one
                    -- shows that the emitted signal was unexpected
                    -- if a signal was expected, shows if actual and expected are unequal
                    display name (Just val) = case M.lookup name opts of
                        Nothing -> putStrLn ("unexpected " ++ unpack name ++ ": " ++ show val)
                        Just expected -> unless (localEval name expected == val) 
                                            (reportError name expected val)

            printInputOutput remaining = forM_ (M.assocs remaining) (uncurry display)
             where  -- no test-error if the input/output is empty 
                    -- (and no input/output was specified)
                    display name [] | Nothing <- M.lookup name opts = return ()
                    display name vals = case M.lookup name opts of
                        Nothing -> putStrLn ("unexpected " ++ unpack name ++ ": " ++ show vals)
                        Just expected -> case localEval name expected of 
                            List exps -> unless (exps == vals) (reportError name expected vals)
                            val -> error ("non-list given as expected output entity ("++
                                        unpack name ++ "): " ++ show val)
                    

-- $moduledoc
-- This module exports functions for creating executables for funcon interpeters.
-- The executables accepts a number of command line and configuration options that
-- are explained here. The /funcons-tools/ package exports an interpreter for
-- the core library of reusable funcons. This executable is called /runfct/ and is used
-- as an example here.
--
-- @ dist\/build\/runfct\/runfct \<options\>@
--
-- === Options
--  Options are used to change the behaviour of the interpreter and to change the
--  output the interpreter provides after execution.
--  An option is either a boolean-option, a string-option, a .config file or a .fct file.
--  All command line flags are considered from left to right,
--    each changing the current configuration.
--
-- (1) __Funcon term file__: A file containing a funcon term. (must have .fct extension). 
--        These files contain funcon terms written 
--          in prefix form with parentheses surrounding comma-separated arguments,
--          e.g. integer-multiply(6,7). The parser also accepts notation for lists, 
--          tuples, sets and map. For example, @[1,2,3]@, @(1,2,3)@, @&#x7b;1,2,3&#x7d;@,
--          and @&#x7b;1 |-> true, 2 |-> false, 3 |-> true &#x7d;@ respectively.
--  
-- (2) __Configurations file__: A file containing configuration options (see below).
--          (must have .config extension)
--  
-- (3) __String options__ (comma-separate strings for multiple inputs):
--
--      * --display-mutable-entity \<string\>: by default mutable entities are not displayed
--            this option is used to display one or more mutable entities.
--
--      * --hide-output-entity \<string\>:
--            by default output entities are displayed when output is available.
--            this option is used to hide one or more output entities.
--
--      * --hide-control-entity \<string\>:
--            by default control entities are displayed when a signal is raised.
--            this option is used to hide one or more control entities .
--
--      * --hide-input-entity \<string\>:
--            by default input entities are displayed when input has not been consumed.
--            this option is used to hide one or more input entities.
--      * --max-restarts \<natural\>:
--          perform a maximum of `n` transitive steps, useful for debugging.
--
-- (4) __Boolean options__ (/true/, /false/ or no argument (/true/ by default)):
--
--      * --refocus \<bool\>: use refocusing, only valid under certain conditions.
--    
--      * --full-environments \<bool\>: when printing funcons, display environments 
--              using map-notation, by default an environment is printed as "...".
--    
--      * --hide-result \<bool\>: do not show the resulting funcon term.
--    
--      * --display-steps \<bool\>: show meta-information about the interpretation, 
--              e.g. the number of steps, rewrites and restarts. 
--    
--      * --no-abrupt-termination \<bool\>: disable abrupt termination (affects uncaught control signals).
--    
--      * --interactive-mode \<bool\>: use real I/O for input and output.
--              By default I/O is simulated and all input is expected to be 
--              provided in a configuration file (see below) and output is collected
--              and displayed after execution is finished.
--              In interactive mode, the user has to provide input via the standard input,
--              and output is printed to the standard output as soon as it is available.
--    
--      * --string-inputs \<bool\>: by default input is parsed into a 'Values'.
--            This option tells the interpreter to yield the given string as input.
--    
--      * --format-string-outputs \<bool\>: if all output values are strings (and with this option on),
--            any escape characters are interpreted (e.g. "\\n" becomes an actual newline), and
--            the strings are concatenated and not enclosed in double quotes.
--    
--      * --hide-tests \<bool\>: do not execute tests (by default tests are executed if specified in a configuration file).
--    
--      * --show-output-only \<bool\>: print only output (omits all other information).
--    
--      * --auto-config \<bool\>: if a .fct file is given, search for a .config file
--            with the same name and apply it (on by default).
--     
-- === Configuration files
--  A configuration file is a sequence of 'fragments', where each fragment is of the form:
--
-- > <group> {
-- >    <keyvalue>*
-- > }
-- 
--  A \<keyvalue\> is a colon separated key-value pair, closed off by a semicolon, e.g.
-- 
-- > hide-control-entity: failed,thrown;
--
--  There are 4 valid groups: /general/, /funcons/, /tests/ and /inputs/.
--  
-- (1) __general__:
--    The general /group/ is used as an alternative to command line flags,
--    All Boolean and string options are available.
--    Additionally, the option "funcon-term" is available for giving an initial 
--    funcon term:
--
--        > general {
--        >     funcon-term: integer-add(3,2);
--        > }
--
-- (2) __funcons__:
--    This group is used to define simple (nullary) funcons.
--    They key is the name of the funcon,
--    the value is a funcon term to which the funcon will rewrite once evaluated.
--    Keys and values are separated by '=' in this group. This group is useful
--    to choose an interpretation for unspecified components of a language specification.
--    For example (from a Caml Light specification):
--
--         > funcons {
--         >     implemented-vectors        = vectors(values);
--         >     implemented-floats-format  = binary64;
--         >     implemented-integers-width = 31;
--         >     implemented-characters     = unicode-characters;
--         >     implemented-strings        = strings;
--         > }
--
-- (3) __tests__:
--    With this group unit-tests can be defined.
--    Each key-value pairs specifies the expected value of a semantic entities,
--    where the key is the name of a semantic entity
--    and the value is the expected value.
--    Additionally, the key "result-term" can be used to specify the expected result term.
--    The tests group is useful to specify a complete unit-test in a single file, e.g.
--
--         > general {
--         >     funcon-term: else(integer-add(integer-add(2,3),fail),print(3));
--         > }
--         > tests {
--         >    result-term: ();
--         >    standard-out: [3];
--         > }
--
-- (4) __inputs__:
--    The inputs group is used to specify default values for input entities, e.g.
--
--         > inputs {
--         >     standard-in: [1,2,3];
--         > }
--
--        When input entities are given default values, simulation mode is turned on
--        (even if --interactive-mode is used).
-- 
-- === Languages specific interpreters
--    This package does not provide just one interpreter, it provides
--    the ability to play `mix and match' with 'FunconLibrary's to form interpreters.
--    This enables the creation of interpreters for object languages from funcons
--    (entities, or datatypes) specific to that object language.
-- 
--    For this purpose, this module exports 'mkMainWithLibraryEntitiesTypes' (and variants). 
--    Say that a module exporting
--    a 'FunconLibrary' is a "funcon module".
--    An interpreter is obtained by importing the chosen "funcon modules" and uniting 
--    their 'FunconLibrary's (with 'libUnions'), perhaps together with default
--    values for entities ('EntityDefault') and information about custom datatypes ('TypeEnv').
--    The resulting maps are given as arguments to 'mkMainWithLibraryEntitiesTypes'
--    (or variant).
--    By using 'mkMainWithLibraryEntitiesTypes', all interpreters inherit the 
--        core reusable funcon library.