module CLaSH.Rewrite.Types where
import Control.Concurrent.Supply (Supply, freshId)
import Control.Lens (use, (.=))
import Control.Monad.Reader (MonadReader, ReaderT, lift)
import Control.Monad.State (MonadState, StateT)
import Control.Monad.Writer (MonadWriter, WriterT)
import Data.HashMap.Strict (HashMap)
import Data.Monoid (Any)
import Unbound.Generics.LocallyNameless (Fresh, FreshMT)
import CLaSH.Core.Term (Term, TmName)
import CLaSH.Core.Type (Type)
import CLaSH.Core.TyCon (TyCon, TyConName)
import CLaSH.Core.Var (Id, TyVar)
import CLaSH.Netlist.Types (HWType)
import CLaSH.Util
data CoreContext = AppFun
| AppArg
| TyAppC
| LetBinding [Id]
| LetBody [Id]
| LamBody Id
| TyLamBody TyVar
| CaseAlt [Id]
| CaseScrut
deriving (Eq,Show)
data RewriteState
= RewriteState
{ _transformCounter :: Int
, _bindings :: HashMap TmName (Type,Term)
, _uniqSupply :: Supply
, _typeTranslator :: HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)
, _tcCache :: HashMap TyConName TyCon
, _evaluator :: HashMap TyConName TyCon -> Term -> Term
}
makeLenses ''RewriteState
data DebugLevel
= DebugNone
| DebugFinal
| DebugName
| DebugApplied
| DebugAll
deriving (Eq,Ord,Read)
newtype RewriteEnv = RE { _dbgLevel :: DebugLevel }
makeLenses ''RewriteEnv
type RewriteSession m = ReaderT RewriteEnv (StateT RewriteState (FreshMT m))
type RewriteMonad m = WriterT Any (RewriteSession m)
instance Monad m => MonadUnique (RewriteMonad m) where
getUniqueM = do
sup <- lift . lift $ use uniqSupply
let (a,sup') = freshId sup
lift . lift $ uniqSupply .= sup'
return a
newtype R m a = R { runR :: RewriteMonad m a }
deriving ( Functor
, Applicative
, Monad
, MonadReader RewriteEnv
, MonadState RewriteState
, MonadWriter Any
, MonadUnique
, Fresh
)
type Transform m = [CoreContext] -> Term -> m Term
type Rewrite m = Transform (R m)