module Program where

import Term ( Identifier )
import Module ( Module )
import SourceText ( ModuleRange )
import qualified Term
import qualified Module
import qualified Log
import qualified Exception
import qualified ControllerBase as Controller

import qualified Control.Monad.Exception.Synchronous as ME
import qualified Control.Monad.Trans.State as MS
import qualified Control.Monad.Trans.Class as MT
import Control.Applicative ( (<$>) )

import qualified Control.Exception as Exc

import qualified System.IO.Strict as StrictIO
import qualified System.IO.Error as Err

import qualified System.Path.PartClass as PartClass
import qualified System.Path as Path
import System.Path.Directory ( doesFileExist )
import System.Path ( (</>) )

import qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Map ( Map )
import Data.Set ( Set )
import Data.Tuple.HT ( mapSnd )

import qualified Control.Functor.HT as FuncHT
import Control.Monad ( foldM, liftM4 )


data Program =
    Program
        { modules :: Map Module.Name Module
        , functions :: Module.FunctionDeclarations
        , constructors :: Module.ConstructorDeclarations
        , controls :: Controller.Assignments
        , controlValues :: Controller.Values
        }
--    deriving (Show)

empty :: Program
empty =
    Program {
        modules = Map.empty,
        functions = Map.empty,
        constructors = Map.empty,
        controls = Map.empty,
        controlValues = Controller.emptyValues
    }

singleton :: Module -> Program
singleton m =
    Program {
        modules = Map.singleton (Module.name m) m,
        functions = Module.functions m,
        constructors = Module.constructors m,
        controls = Module.controls m,
        controlValues = Controller.emptyValues
    }

{- |
add a module

The module must not be present in the program,
otherwise this function returns an invalid 'Program'.
-}
addModule :: Module -> Program -> Exception.Monad Program
addModule m p =
    liftM4
        ( Program ( Map.insert ( Module.name m ) m ( modules p ) ) )
        ( unionDecls ( Module.functions m ) ( functions p ) )
        ( Map.map fst <$>
          unionDecls
              ( flip (,) () <$> Module.constructors m )
              ( flip (,) () <$> constructors p ) )
        ( Controller.union
              ( Controller.updateValues
                    ( controlValues p ) ( Module.controls m ) )
              ( controls p ) )
        ( return $ controlValues p )

removeModule ::
    Module.Name -> Program -> Program
removeModule nm p =
    case Map.lookup nm $ modules p of
        Nothing -> p
        Just m -> Program {
            modules = Map.delete nm $ modules p,
            functions = Map.difference ( functions p ) ( Module.functions m ),
            constructors =
                Map.difference ( constructors p ) ( Module.constructors m ),
            controls = Map.difference ( controls p ) ( Module.controls m ),
            controlValues = controlValues p
          }

replaceModule :: Module -> Program -> Exception.Monad Program
replaceModule m p =
    addModule m $ removeModule (Module.name m) p


unionDecls ::
    Map Module.Identifier (Identifier ModuleRange, a) ->
    Map Module.Identifier (Identifier ModuleRange, a) ->
    Exception.Monad ( Map Module.Identifier (Identifier ModuleRange, a) )
unionDecls m0 m1 =
    let f = fmap (mapSnd ME.Success)
    in
     Trav.traverse (FuncHT.mapSnd id) $
     Map.unionWith
        (\(n0,_) (n1,_) ->
            (n0,
             ME.Exception $
             Exception.messageParseModuleRange (Term.range n0)
                 ("duplicate definition of " ++ show n0 ++
                  " in " ++ (Module.deconsName $ Module.nameFromIdentifier n0) ++
                  " and " ++ (Module.deconsName $ Module.nameFromIdentifier n1))))
        (f m0) (f m1)


minimize :: Module.Name -> Program -> (Set Module.Name, Program)
minimize seed p =
    let trace modName ms =
            if Set.member modName ms
              then foldl (flip trace) (Set.delete modName ms) $
                   maybe [] (map Module.source . Module.imports) $
                   Map.lookup modName (modules p)
              else ms
        removed = trace seed $ Map.keysSet $ modules p
    in  (removed, Fold.foldl (flip removeModule) p removed)


-- | load from disk, with import chasing
chase ::
    [ Path.AbsDir ] -> Module.Version ->
    Module.Name -> Exception.MonadT IO Program
chase dirs vers n =
    chaser dirs vers empty n

chaser ::
    [ Path.AbsDir ] -> Module.Version ->
    Program -> Module.Name -> Exception.MonadT IO Program
chaser dirs vers p n = do
    MT.lift $ Log.put $ "chasing " ++ Module.tellName n
    case Map.lookup n ( modules p ) of
        Just _ -> MT.lift $ do
            Log.put $ "module is already loaded"
            return p
        Nothing -> do
            path <- chaseFile dirs ( Module.makeFileName n )
            snd <$> load dirs vers path p

chaseMany ::
    [ Path.AbsDir ] -> Module.Version ->
    [ Module.Name ] -> Program -> Exception.MonadT IO Program
chaseMany dirs vers names p =
    foldM ( chaser dirs vers ) p names

chaseImports ::
    [ Path.AbsDir ] -> Module.Version ->
    Module.Module -> Program -> Exception.MonadT IO Program
chaseImports dirs vers =
    chaseMany dirs vers . map Module.source . Module.imports

load ::
    [ Path.AbsDir ] -> Module.Version -> Path.AbsFile -> Program ->
    Exception.MonadT IO (Module.Name, Program)
load dirs vers ff p = do
    content <-
        ME.mapExceptionT
            (\e ->
                Exception.messageInOut
                    (Module.File ff)
                    (Err.ioeGetErrorString e)) $
        ME.fromEitherT $ Exc.try $ StrictIO.readFile $ Path.toString ff
    m <- ME.liftT $ Module.parse vers Nothing ff content
    MT.lift $ Log.put $ show m
    fmap ((,) (Module.name m)) $
        chaseImports dirs vers m =<< ME.liftT ( addModule m p )

{- |
If a file is not found, we setup an empty module.
If a file exists but contains parse errors then we abort loading.
-}
loadMany ::
    [ Path.AbsDir ] -> Module.Version -> [ Module.Name ] ->
    Exception.MonadT IO ([Module.Name], Program)
loadMany dirs vers =
    flip MS.runStateT empty .
    mapM
        (\name -> do
            epath <-
                MT.lift $ MT.lift $ ME.tryT $
                chaseFile dirs $ Module.makeFileName name
            MS.StateT $
                case epath of
                    ME.Success path -> load dirs vers path
                    ME.Exception _ ->
                        fmap ((,) name) . ME.liftT .
                        addModule (Module.empty name))


-- | look for file, trying to append its name to the directories in the path,
-- in turn. Will fail if file is not found.
chaseFile ::
    (PartClass.AbsRel ar) =>
    [ Path.Dir ar ] -> Path.RelFile -> Exception.MonadT IO (Path.File ar)
chaseFile dirs f =
    foldr
        (\dir go -> do
            let ff = dir </> f
            e <- MT.lift $ doesFileExist ff
            if e
              then MT.lift $ do
                Log.put $ "found at location " ++ Path.toString ff
                return ff
              else go)
        (ME.throwT $
         Exception.messageInOut
             (Module.Editor Module.noName)
             ("module not found: " ++ Path.toString f))
        dirs