FuseEnvironment.lhs

-- Please, see the file LICENSE for copyright and license information.

A monad to keep an environment with hylomorphism definitions and throwing errors.

>module HFusion.Internal.FuseEnvironment(
>                       clearFuseEnv,
>                       insertFuseEnv,
>                       deleteFuseEnv,
>                       lookupFuseEnv,
>                       fuseFuseEnv,
>                       renameFuseEnv,
>                       toListFuseEnv,
>                       runEnv,
>                       env2FusionState,
>                       Binds,
>                       emptyBinds,
>                       Env) where

> import HFusion.Internal.Utils(newVarGen)
> import Control.Monad.State(State,StateT(..),get,put,evalStateT)
> import Control.Monad.Error(throwError,ErrorT)
> import Control.Monad.Trans(lift)
> import Data.Map(empty,Map,insert,lookup,delete,toList)
> import HFusion.Internal.Utils(VarGen)
> import HFusion.Internal.HyloFace
> import List(elemIndex)
> import HFusion.Internal.FuseFace(fusionar,HyloT,getNames,renameHT)

 data Key a = SingleKey a | KeyList [a]

> type Binds = (Map [Variable] HyloT,Map Variable [Variable])
> type Env a = StateT Binds (ErrorT FusionError (State VarGen)) a

> emptyBinds :: Binds
> emptyBinds = (empty,empty)

> env2FusionState :: Env a -> FusionState a
> env2FusionState m = evalStateT m emptyBinds

> runEnv :: Env a -> Either FusionError a
> runEnv = runFusionState newVarGen . env2FusionState

> clearFuseEnv :: Env ()
> clearFuseEnv = put emptyBinds

> insertFuseEnv :: HyloT -> Env ()
> insertFuseEnv h = do (mh,mv)<-get;put (insert names h mh,foldr (flip insert names) mv names)
>  where names = getNames h

> deleteFuseEnv :: Variable -> Env ()
> deleteFuseEnv v = do (mh,mv)<-get
>                      maybe (return ()) (\ns -> put (delete ns mh,foldr delete mv ns)) (Data.Map.lookup v mv)

> lookupFuseEnv :: Variable -> Env HyloT
> lookupFuseEnv v = do (mh,mv)<-get 
>                      maybe err (maybe err return . flip Data.Map.lookup mh) (Data.Map.lookup v mv)
>   where err = throwError (NotFound (show v))

> fuseFuseEnv :: [Variable] -> Variable -> Int -> Variable -> Env HyloT
> fuseFuseEnv names v1 ia v2 = 
>       do h1<-lookupFuseEnv v1
>          h2<-lookupFuseEnv v2
>          let getIndex v h = maybe (error "fuseFuseEnv: this should not happen.") id $ elemIndex v (getNames h)
>          (_,_,h3)<-lift (fusionar names h1 (getIndex v1 h1) ia h2 (getIndex v2 h2))
>          insertFuseEnv h3
>          return h3

> renameFuseEnv :: Variable -> Variable -> Env (HyloT,HyloT)
> renameFuseEnv v1 v2 = do h1<-lookupFuseEnv v1
>                          h2<-lookupFuseEnv v2
>                          lift (renameHT h1 h2)

> toListFuseEnv :: Env [([Variable],HyloT)]
> toListFuseEnv = get >>= return . toList . fst