{-|
  Copyright  :  (C) 2012-2016, University of Twente,
                    2016     , Myrtle Software Ltd,
                    2017     , Google Inc.
  License    :  BSD2 (see the file LICENSE)
  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>

  Type and instance definitions for Rewrite modules
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.Rewrite.Types where

import Control.Concurrent.Supply             (Supply, freshId)
import Control.DeepSeq                       (NFData)
import Control.Lens                          (Lens', use, (.=))
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail                    (MonadFail(fail))
#endif
import Control.Monad.Fix                     (MonadFix (..), fix)
import Control.Monad.Reader                  (MonadReader (..))
import Control.Monad.State                   (MonadState (..))
import Control.Monad.State.Strict            (State)
import Control.Monad.Writer                  (MonadWriter (..))
import Data.Binary                           (Binary)
import Data.Hashable                         (Hashable)
import Data.IntMap.Strict                    (IntMap)
import Data.Monoid                           (Any)
import qualified Data.Set                    as Set
import GHC.Generics

#if EXPERIMENTAL_EVALUATOR
import Clash.Core.PartialEval                (Evaluator)
import Clash.Core.PartialEval.NormalForm     (Value)
#else
import Clash.Core.Evaluator.Types            (Evaluator, PrimHeap)
#endif

import Clash.Core.Term           (Term, Context)
import Clash.Core.Type           (Type)
import Clash.Core.TyCon          (TyConName, TyConMap)
import Clash.Core.Var            (Id)
import Clash.Core.VarEnv         (InScopeSet, VarSet, VarEnv)
import Clash.Driver.Types        (BindingMap, DebugLevel)
import Clash.Netlist.Types       (FilteredHWType, HWMap)
import Clash.Rewrite.WorkFree    (isWorkFree)
import Clash.Util

import Clash.Annotations.BitRepresentation.Internal (CustomReprs)

-- | State used by the inspection mechanism for recording rewrite steps.
data RewriteStep
  = RewriteStep
  { RewriteStep -> Context
t_ctx    :: Context
  -- ^ current context
  , RewriteStep -> String
t_name   :: String
  -- ^ Name of the transformation
  , RewriteStep -> String
t_bndrS  :: String
  -- ^ Name of the current binder
  , RewriteStep -> Term
t_before :: Term
  -- ^ Term before `apply`
  , RewriteStep -> Term
t_after  :: Term
  -- ^ Term after `apply`
  } deriving (Int -> RewriteStep -> ShowS
[RewriteStep] -> ShowS
RewriteStep -> String
(Int -> RewriteStep -> ShowS)
-> (RewriteStep -> String)
-> ([RewriteStep] -> ShowS)
-> Show RewriteStep
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RewriteStep] -> ShowS
$cshowList :: [RewriteStep] -> ShowS
show :: RewriteStep -> String
$cshow :: RewriteStep -> String
showsPrec :: Int -> RewriteStep -> ShowS
$cshowsPrec :: Int -> RewriteStep -> ShowS
Show, (forall x. RewriteStep -> Rep RewriteStep x)
-> (forall x. Rep RewriteStep x -> RewriteStep)
-> Generic RewriteStep
forall x. Rep RewriteStep x -> RewriteStep
forall x. RewriteStep -> Rep RewriteStep x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RewriteStep x -> RewriteStep
$cfrom :: forall x. RewriteStep -> Rep RewriteStep x
Generic, RewriteStep -> ()
(RewriteStep -> ()) -> NFData RewriteStep
forall a. (a -> ()) -> NFData a
rnf :: RewriteStep -> ()
$crnf :: RewriteStep -> ()
NFData, Int -> RewriteStep -> Int
RewriteStep -> Int
(Int -> RewriteStep -> Int)
-> (RewriteStep -> Int) -> Hashable RewriteStep
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: RewriteStep -> Int
$chash :: RewriteStep -> Int
hashWithSalt :: Int -> RewriteStep -> Int
$chashWithSalt :: Int -> RewriteStep -> Int
Hashable, Get RewriteStep
[RewriteStep] -> Put
RewriteStep -> Put
(RewriteStep -> Put)
-> Get RewriteStep -> ([RewriteStep] -> Put) -> Binary RewriteStep
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [RewriteStep] -> Put
$cputList :: [RewriteStep] -> Put
get :: Get RewriteStep
$cget :: Get RewriteStep
put :: RewriteStep -> Put
$cput :: RewriteStep -> Put
Binary)

-- | State of a rewriting session
data RewriteState extra
  = RewriteState
  { RewriteState extra -> Int
_transformCounter :: {-# UNPACK #-} !Int
  -- ^ Number of applied transformations
  , RewriteState extra -> BindingMap
_bindings         :: !BindingMap
  -- ^ Global binders
  , RewriteState extra -> Supply
_uniqSupply       :: !Supply
  -- ^ Supply of unique numbers
  , RewriteState extra -> (Id, SrcSpan)
_curFun           :: (Id,SrcSpan) -- Initially set to undefined: no strictness annotation
  -- ^ Function which is currently normalized
  , RewriteState extra -> Int
_nameCounter      :: {-# UNPACK #-} !Int
  -- ^ Used for 'Fresh'
#if EXPERIMENTAL_EVALUATOR
  , _ioHeap           :: IntMap Value
  -- ^ Used as a heap for compile-time evaluation of primitives that live in I/O
  , _ioAddr           :: Int
  -- ^ Next address to use for heap insertion.
#else
  , RewriteState extra -> PrimHeap
_globalHeap       :: PrimHeap
  -- ^ Used as a heap for compile-time evaluation of primitives that live in I/O
#endif
  , RewriteState extra -> VarEnv Bool
_workFreeBinders  :: VarEnv Bool
  -- ^ Map telling whether a binder's definition is work-free
  , RewriteState extra -> extra
_extra            :: !extra
  -- ^ Additional state
  }

makeLenses ''RewriteState

-- | Read-only environment of a rewriting session
data RewriteEnv
  = RewriteEnv
  { RewriteEnv -> DebugLevel
_dbgLevel       :: DebugLevel
  -- ^ Level at which we print debugging messages
  , RewriteEnv -> Set String
_dbgTransformations :: Set.Set String
  -- ^ See ClashOpts.dbgTransformations
  , RewriteEnv -> Int
_dbgTransformationsFrom :: Int
  -- ^ See ClashOpts.opt_dbgTransformationsFrom
  , RewriteEnv -> Int
_dbgTransformationsLimit :: Int
  -- ^ See ClashOpts.opt_dbgTransformationsLimit
  , RewriteEnv -> Maybe String
_dbgRewriteHistoryFile :: Maybe FilePath
  -- ^ See ClashOpts.opt_dbgRewriteHistory
  , RewriteEnv -> Bool
_aggressiveXOpt :: Bool
  -- ^ Transformations to print debugging info for
  , RewriteEnv
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
_typeTranslator :: CustomReprs
                    -> TyConMap
                    -> Type
                    -> State HWMap (Maybe (Either String FilteredHWType))
  -- ^ Hardcode Type -> FilteredHWType translator
  , RewriteEnv -> TyConMap
_tcCache        :: TyConMap
  -- ^ TyCon cache
  , RewriteEnv -> IntMap TyConName
_tupleTcCache   :: IntMap TyConName
  -- ^ Tuple TyCon cache
  , RewriteEnv -> Evaluator
_evaluator      :: Evaluator
  -- ^ Hardcoded evaluator for partial evaluation
  , RewriteEnv -> VarSet
_topEntities    :: VarSet
  -- ^ Functions that are considered TopEntities
  , RewriteEnv -> CustomReprs
_customReprs    :: CustomReprs
  -- ^ Custom bit representations
  , RewriteEnv -> Word
_fuelLimit      :: Word
  -- ^ Maximum amount of fuel for the evaluator
  }

makeLenses ''RewriteEnv

-- | Monad that keeps track how many transformations have been applied and can
-- generate fresh variables and unique identifiers. In addition, it keeps track
-- if a transformation/rewrite has been successfully applied.
newtype RewriteMonad extra a = R
  { RewriteMonad extra a
-> RewriteEnv
-> RewriteState extra
-> Any
-> (a, RewriteState extra, Any)
unR :: RewriteEnv -> RewriteState extra -> Any -> (a,RewriteState extra,Any) }

-- | Run the computation in the RewriteMonad
runR
  :: RewriteMonad extra a
  -> RewriteEnv
  -> RewriteState extra
  -> (a, RewriteState extra, Any)
runR :: RewriteMonad extra a
-> RewriteEnv -> RewriteState extra -> (a, RewriteState extra, Any)
runR RewriteMonad extra a
m RewriteEnv
r RewriteState extra
s = RewriteMonad extra a
-> RewriteEnv
-> RewriteState extra
-> Any
-> (a, RewriteState extra, Any)
forall extra a.
RewriteMonad extra a
-> RewriteEnv
-> RewriteState extra
-> Any
-> (a, RewriteState extra, Any)
unR RewriteMonad extra a
m RewriteEnv
r RewriteState extra
s Any
forall a. Monoid a => a
mempty

instance MonadFail (RewriteMonad extra) where
  fail :: String -> RewriteMonad extra a
fail String
err = String -> RewriteMonad extra a
forall a. HasCallStack => String -> a
error (String
"RewriteMonad.fail: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err)

instance Functor (RewriteMonad extra) where
  fmap :: (a -> b) -> RewriteMonad extra a -> RewriteMonad extra b
fmap a -> b
f RewriteMonad extra a
m = (RewriteEnv
 -> RewriteState extra -> Any -> (b, RewriteState extra, Any))
-> RewriteMonad extra b
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> (b, RewriteState extra, Any))
 -> RewriteMonad extra b)
-> (RewriteEnv
    -> RewriteState extra -> Any -> (b, RewriteState extra, Any))
-> RewriteMonad extra b
forall a b. (a -> b) -> a -> b
$ \ RewriteEnv
r RewriteState extra
s Any
w -> case RewriteMonad extra a
-> RewriteEnv
-> RewriteState extra
-> Any
-> (a, RewriteState extra, Any)
forall extra a.
RewriteMonad extra a
-> RewriteEnv
-> RewriteState extra
-> Any
-> (a, RewriteState extra, Any)
unR RewriteMonad extra a
m RewriteEnv
r RewriteState extra
s Any
w of (a
a, RewriteState extra
s', Any
w') -> (a -> b
f a
a, RewriteState extra
s', Any
w')
  {-# INLINE fmap #-}

instance Applicative (RewriteMonad extra) where
  pure :: a -> RewriteMonad extra a
pure a
a = (RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
 -> RewriteMonad extra a)
-> (RewriteEnv
    -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall a b. (a -> b) -> a -> b
$ \ RewriteEnv
_ RewriteState extra
s Any
w -> (a
a, RewriteState extra
s, Any
w)
  {-# INLINE pure #-}
  R RewriteEnv
-> RewriteState extra -> Any -> (a -> b, RewriteState extra, Any)
mf <*> :: RewriteMonad extra (a -> b)
-> RewriteMonad extra a -> RewriteMonad extra b
<*> R RewriteEnv
-> RewriteState extra -> Any -> (a, RewriteState extra, Any)
mx = (RewriteEnv
 -> RewriteState extra -> Any -> (b, RewriteState extra, Any))
-> RewriteMonad extra b
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> (b, RewriteState extra, Any))
 -> RewriteMonad extra b)
-> (RewriteEnv
    -> RewriteState extra -> Any -> (b, RewriteState extra, Any))
-> RewriteMonad extra b
forall a b. (a -> b) -> a -> b
$ \ RewriteEnv
r RewriteState extra
s Any
w -> case RewriteEnv
-> RewriteState extra -> Any -> (a -> b, RewriteState extra, Any)
mf RewriteEnv
r RewriteState extra
s Any
w of
    (a -> b
f,RewriteState extra
s',Any
w') -> case RewriteEnv
-> RewriteState extra -> Any -> (a, RewriteState extra, Any)
mx RewriteEnv
r RewriteState extra
s' Any
w' of
      (a
x,RewriteState extra
s'',Any
w'') -> (a -> b
f a
x, RewriteState extra
s'', Any
w'')
  {-# INLINE (<*>) #-}

instance Monad (RewriteMonad extra) where
  return :: a -> RewriteMonad extra a
return a
a = (RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
 -> RewriteMonad extra a)
-> (RewriteEnv
    -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall a b. (a -> b) -> a -> b
$ \ RewriteEnv
_ RewriteState extra
s Any
w -> (a
a, RewriteState extra
s, Any
w)
  {-# INLINE return #-}
  RewriteMonad extra a
m >>= :: RewriteMonad extra a
-> (a -> RewriteMonad extra b) -> RewriteMonad extra b
>>= a -> RewriteMonad extra b
k  =
    (RewriteEnv
 -> RewriteState extra -> Any -> (b, RewriteState extra, Any))
-> RewriteMonad extra b
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> (b, RewriteState extra, Any))
 -> RewriteMonad extra b)
-> (RewriteEnv
    -> RewriteState extra -> Any -> (b, RewriteState extra, Any))
-> RewriteMonad extra b
forall a b. (a -> b) -> a -> b
$ \ RewriteEnv
r RewriteState extra
s Any
w -> case RewriteMonad extra a
-> RewriteEnv
-> RewriteState extra
-> Any
-> (a, RewriteState extra, Any)
forall extra a.
RewriteMonad extra a
-> RewriteEnv
-> RewriteState extra
-> Any
-> (a, RewriteState extra, Any)
unR RewriteMonad extra a
m RewriteEnv
r RewriteState extra
s Any
w of
      (a
a,RewriteState extra
s',Any
w') -> RewriteMonad extra b
-> RewriteEnv
-> RewriteState extra
-> Any
-> (b, RewriteState extra, Any)
forall extra a.
RewriteMonad extra a
-> RewriteEnv
-> RewriteState extra
-> Any
-> (a, RewriteState extra, Any)
unR (a -> RewriteMonad extra b
k a
a) RewriteEnv
r RewriteState extra
s' Any
w'
  {-# INLINE (>>=) #-}


instance MonadState (RewriteState extra) (RewriteMonad extra) where
  get :: RewriteMonad extra (RewriteState extra)
get = (RewriteEnv
 -> RewriteState extra
 -> Any
 -> (RewriteState extra, RewriteState extra, Any))
-> RewriteMonad extra (RewriteState extra)
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra
  -> Any
  -> (RewriteState extra, RewriteState extra, Any))
 -> RewriteMonad extra (RewriteState extra))
-> (RewriteEnv
    -> RewriteState extra
    -> Any
    -> (RewriteState extra, RewriteState extra, Any))
-> RewriteMonad extra (RewriteState extra)
forall a b. (a -> b) -> a -> b
$ \RewriteEnv
_ RewriteState extra
s Any
w -> (RewriteState extra
s,RewriteState extra
s,Any
w)
  {-# INLINE get #-}
  put :: RewriteState extra -> RewriteMonad extra ()
put RewriteState extra
s = (RewriteEnv
 -> RewriteState extra -> Any -> ((), RewriteState extra, Any))
-> RewriteMonad extra ()
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> ((), RewriteState extra, Any))
 -> RewriteMonad extra ())
-> (RewriteEnv
    -> RewriteState extra -> Any -> ((), RewriteState extra, Any))
-> RewriteMonad extra ()
forall a b. (a -> b) -> a -> b
$ \RewriteEnv
_ RewriteState extra
_ Any
w -> ((),RewriteState extra
s,Any
w)
  {-# INLINE put #-}
  state :: (RewriteState extra -> (a, RewriteState extra))
-> RewriteMonad extra a
state RewriteState extra -> (a, RewriteState extra)
f = (RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
 -> RewriteMonad extra a)
-> (RewriteEnv
    -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall a b. (a -> b) -> a -> b
$ \RewriteEnv
_ RewriteState extra
s Any
w -> case RewriteState extra -> (a, RewriteState extra)
f RewriteState extra
s of (a
a,RewriteState extra
s') -> (a
a,RewriteState extra
s',Any
w)
  {-# INLINE state #-}

instance MonadUnique (RewriteMonad extra) where
  getUniqueM :: RewriteMonad extra Int
getUniqueM = do
    Supply
sup <- Getting Supply (RewriteState extra) Supply
-> RewriteMonad extra Supply
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting Supply (RewriteState extra) Supply
forall extra. Lens' (RewriteState extra) Supply
uniqSupply
    let (Int
a,Supply
sup') = Supply -> (Int, Supply)
freshId Supply
sup
    (Supply -> Identity Supply)
-> RewriteState extra -> Identity (RewriteState extra)
forall extra. Lens' (RewriteState extra) Supply
uniqSupply ((Supply -> Identity Supply)
 -> RewriteState extra -> Identity (RewriteState extra))
-> Supply -> RewriteMonad extra ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Supply
sup'
    Int
a Int -> RewriteMonad extra Int -> RewriteMonad extra Int
`seq` Int -> RewriteMonad extra Int
forall (m :: Type -> Type) a. Monad m => a -> m a
return Int
a

instance MonadWriter Any (RewriteMonad extra) where
  writer :: (a, Any) -> RewriteMonad extra a
writer (a
a,Any
w') = (RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
 -> RewriteMonad extra a)
-> (RewriteEnv
    -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall a b. (a -> b) -> a -> b
$ \RewriteEnv
_ RewriteState extra
s Any
w -> let wt :: Any
wt = Any
w Any -> Any -> Any
forall a. Monoid a => a -> a -> a
`mappend` Any
w' in Any
wt Any -> (a, RewriteState extra, Any) -> (a, RewriteState extra, Any)
`seq` (a
a,RewriteState extra
s,Any
wt)
  {-# INLINE writer #-}
  tell :: Any -> RewriteMonad extra ()
tell Any
w' = (RewriteEnv
 -> RewriteState extra -> Any -> ((), RewriteState extra, Any))
-> RewriteMonad extra ()
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> ((), RewriteState extra, Any))
 -> RewriteMonad extra ())
-> (RewriteEnv
    -> RewriteState extra -> Any -> ((), RewriteState extra, Any))
-> RewriteMonad extra ()
forall a b. (a -> b) -> a -> b
$ \RewriteEnv
_ RewriteState extra
s Any
w -> let wt :: Any
wt = Any
w Any -> Any -> Any
forall a. Monoid a => a -> a -> a
`mappend` Any
w' in Any
wt Any
-> ((), RewriteState extra, Any) -> ((), RewriteState extra, Any)
`seq` ((),RewriteState extra
s,Any
wt)
  {-# INLINE tell #-}
  listen :: RewriteMonad extra a -> RewriteMonad extra (a, Any)
listen RewriteMonad extra a
m = (RewriteEnv
 -> RewriteState extra
 -> Any
 -> ((a, Any), RewriteState extra, Any))
-> RewriteMonad extra (a, Any)
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra
  -> Any
  -> ((a, Any), RewriteState extra, Any))
 -> RewriteMonad extra (a, Any))
-> (RewriteEnv
    -> RewriteState extra
    -> Any
    -> ((a, Any), RewriteState extra, Any))
-> RewriteMonad extra (a, Any)
forall a b. (a -> b) -> a -> b
$ \RewriteEnv
r RewriteState extra
s Any
w -> case RewriteMonad extra a
-> RewriteEnv -> RewriteState extra -> (a, RewriteState extra, Any)
forall extra a.
RewriteMonad extra a
-> RewriteEnv -> RewriteState extra -> (a, RewriteState extra, Any)
runR RewriteMonad extra a
m RewriteEnv
r RewriteState extra
s of
    (a
a,RewriteState extra
s',Any
w') -> let wt :: Any
wt = Any
w Any -> Any -> Any
forall a. Monoid a => a -> a -> a
`mappend` Any
w' in Any
wt Any
-> ((a, Any), RewriteState extra, Any)
-> ((a, Any), RewriteState extra, Any)
`seq` ((a
a,Any
w'),RewriteState extra
s',Any
wt)
  {-# INLINE listen #-}
  pass :: RewriteMonad extra (a, Any -> Any) -> RewriteMonad extra a
pass RewriteMonad extra (a, Any -> Any)
m = (RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
 -> RewriteMonad extra a)
-> (RewriteEnv
    -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall a b. (a -> b) -> a -> b
$ \RewriteEnv
r RewriteState extra
s Any
w -> case RewriteMonad extra (a, Any -> Any)
-> RewriteEnv
-> RewriteState extra
-> ((a, Any -> Any), RewriteState extra, Any)
forall extra a.
RewriteMonad extra a
-> RewriteEnv -> RewriteState extra -> (a, RewriteState extra, Any)
runR RewriteMonad extra (a, Any -> Any)
m RewriteEnv
r RewriteState extra
s of
    ((a
a,Any -> Any
f),RewriteState extra
s',Any
w') -> let wt :: Any
wt = Any
w Any -> Any -> Any
forall a. Monoid a => a -> a -> a
`mappend` Any -> Any
f Any
w' in Any
wt Any -> (a, RewriteState extra, Any) -> (a, RewriteState extra, Any)
`seq` (a
a, RewriteState extra
s', Any
wt)
  {-# INLINE pass #-}

censor :: (Any -> Any) -> RewriteMonad extra a -> RewriteMonad extra a
censor :: (Any -> Any) -> RewriteMonad extra a -> RewriteMonad extra a
censor Any -> Any
f RewriteMonad extra a
m = (RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
 -> RewriteMonad extra a)
-> (RewriteEnv
    -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall a b. (a -> b) -> a -> b
$ \RewriteEnv
r RewriteState extra
s Any
w -> case RewriteMonad extra a
-> RewriteEnv -> RewriteState extra -> (a, RewriteState extra, Any)
forall extra a.
RewriteMonad extra a
-> RewriteEnv -> RewriteState extra -> (a, RewriteState extra, Any)
runR RewriteMonad extra a
m RewriteEnv
r RewriteState extra
s of
  (a
a,RewriteState extra
s',Any
w') -> let wt :: Any
wt = Any
w Any -> Any -> Any
forall a. Monoid a => a -> a -> a
`mappend` Any -> Any
f Any
w' in Any
wt Any -> (a, RewriteState extra, Any) -> (a, RewriteState extra, Any)
`seq` (a
a, RewriteState extra
s', Any
wt)
{-# INLINE censor #-}

instance MonadReader RewriteEnv (RewriteMonad extra) where
   ask :: RewriteMonad extra RewriteEnv
ask = (RewriteEnv
 -> RewriteState extra
 -> Any
 -> (RewriteEnv, RewriteState extra, Any))
-> RewriteMonad extra RewriteEnv
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra
  -> Any
  -> (RewriteEnv, RewriteState extra, Any))
 -> RewriteMonad extra RewriteEnv)
-> (RewriteEnv
    -> RewriteState extra
    -> Any
    -> (RewriteEnv, RewriteState extra, Any))
-> RewriteMonad extra RewriteEnv
forall a b. (a -> b) -> a -> b
$ \RewriteEnv
r RewriteState extra
s Any
w -> (RewriteEnv
r,RewriteState extra
s,Any
w)
   {-# INLINE ask #-}
   local :: (RewriteEnv -> RewriteEnv)
-> RewriteMonad extra a -> RewriteMonad extra a
local RewriteEnv -> RewriteEnv
f RewriteMonad extra a
m = (RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
 -> RewriteMonad extra a)
-> (RewriteEnv
    -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall a b. (a -> b) -> a -> b
$ \RewriteEnv
r RewriteState extra
s Any
w -> RewriteMonad extra a
-> RewriteEnv
-> RewriteState extra
-> Any
-> (a, RewriteState extra, Any)
forall extra a.
RewriteMonad extra a
-> RewriteEnv
-> RewriteState extra
-> Any
-> (a, RewriteState extra, Any)
unR RewriteMonad extra a
m (RewriteEnv -> RewriteEnv
f RewriteEnv
r) RewriteState extra
s Any
w
   {-# INLINE local #-}
   reader :: (RewriteEnv -> a) -> RewriteMonad extra a
reader RewriteEnv -> a
f = (RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
 -> RewriteMonad extra a)
-> (RewriteEnv
    -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall a b. (a -> b) -> a -> b
$ \RewriteEnv
r RewriteState extra
s Any
w -> (RewriteEnv -> a
f RewriteEnv
r,RewriteState extra
s,Any
w)
   {-# INLINE reader #-}

instance MonadFix (RewriteMonad extra) where
  mfix :: (a -> RewriteMonad extra a) -> RewriteMonad extra a
mfix a -> RewriteMonad extra a
f = (RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall extra a.
(RewriteEnv
 -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
R ((RewriteEnv
  -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
 -> RewriteMonad extra a)
-> (RewriteEnv
    -> RewriteState extra -> Any -> (a, RewriteState extra, Any))
-> RewriteMonad extra a
forall a b. (a -> b) -> a -> b
$ \RewriteEnv
r RewriteState extra
s Any
w -> ((a, RewriteState extra, Any) -> (a, RewriteState extra, Any))
-> (a, RewriteState extra, Any)
forall a. (a -> a) -> a
fix (((a, RewriteState extra, Any) -> (a, RewriteState extra, Any))
 -> (a, RewriteState extra, Any))
-> ((a, RewriteState extra, Any) -> (a, RewriteState extra, Any))
-> (a, RewriteState extra, Any)
forall a b. (a -> b) -> a -> b
$ \ ~(a
a,RewriteState extra
_,Any
_) -> RewriteMonad extra a
-> RewriteEnv
-> RewriteState extra
-> Any
-> (a, RewriteState extra, Any)
forall extra a.
RewriteMonad extra a
-> RewriteEnv
-> RewriteState extra
-> Any
-> (a, RewriteState extra, Any)
unR (a -> RewriteMonad extra a
f a
a) RewriteEnv
r RewriteState extra
s Any
w
  {-# INLINE mfix #-}

data TransformContext
  = TransformContext
  { TransformContext -> InScopeSet
tfInScope :: !InScopeSet
  , TransformContext -> Context
tfContext :: Context
  }

-- | Monadic action that transforms a term given a certain context
type Transform m = TransformContext -> Term -> m Term

-- | A 'Transform' action in the context of the 'RewriteMonad'
type Rewrite extra = Transform (RewriteMonad extra)

-- Moved into Clash.Rewrite.WorkFree
{-# SPECIALIZE isWorkFree
      :: Lens' (RewriteState extra) (VarEnv Bool)
      -> BindingMap
      -> Term
      -> RewriteMonad extra Bool
  #-}