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