{-|
  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 FlexibleInstances          #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}

module Clash.Rewrite.Types where

import Control.Concurrent.Supply             (Supply, freshId)
import Control.DeepSeq                       (NFData)
import Control.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 GHC.Generics

import Clash.Core.Evaluator      (GlobalHeap, PrimEvaluator)
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)
import Clash.Driver.Types        (BindingMap, DebugLevel)
import Clash.Netlist.Types       (FilteredHWType, HWMap)
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'
  , RewriteState extra -> GlobalHeap
_globalHeap       :: GlobalHeap
  -- ^ Used as a heap for compile-time evaluation of primitives that live in I/O
  , RewriteState extra -> extra
_extra            :: !extra
  -- ^ Additional state
  }

makeLenses ''RewriteState

-- | Read-only environment of a rewriting session
data RewriteEnv
  = RewriteEnv
  { RewriteEnv -> DebugLevel
_dbgLevel       :: DebugLevel
  -- ^ Lvl at which we print debugging messages
  , 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 -> PrimEvaluator
_evaluator      :: PrimEvaluator
  -- ^ Hardcoded evaluator (delta-reduction)}
  , RewriteEnv -> VarSet
_topEntities    :: VarSet
  -- ^ Functions that are considered TopEntities
  , RewriteEnv -> CustomReprs
_customReprs    :: CustomReprs
  -- ^ Custom bit representations
  }

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 m :: RewriteMonad extra a
m r :: RewriteEnv
r s :: 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 err :: String
err = String -> RewriteMonad extra a
forall a. HasCallStack => String -> a
error ("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 f :: a -> b
f m :: 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
$ \ r :: RewriteEnv
r s :: RewriteState extra
s w :: 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
a, s' :: RewriteState extra
s', w' :: 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
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
$ \ _ s :: RewriteState extra
s w :: Any
w -> (a
a, RewriteState extra
s, Any
w)
  {-# INLINE pure #-}
  R mf :: RewriteEnv
-> RewriteState extra -> Any -> (a -> b, RewriteState extra, Any)
mf <*> :: RewriteMonad extra (a -> b)
-> RewriteMonad extra a -> RewriteMonad extra b
<*> R mx :: 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
$ \ r :: RewriteEnv
r s :: RewriteState extra
s w :: Any
w -> case RewriteEnv
-> RewriteState extra -> Any -> (a -> b, RewriteState extra, Any)
mf RewriteEnv
r RewriteState extra
s Any
w of
    (f :: a -> b
f,s' :: RewriteState extra
s',w' :: Any
w') -> case RewriteEnv
-> RewriteState extra -> Any -> (a, RewriteState extra, Any)
mx RewriteEnv
r RewriteState extra
s' Any
w' of
      (x :: a
x,s'' :: RewriteState extra
s'',w'' :: 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
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
$ \ _ s :: RewriteState extra
s w :: Any
w -> (a
a, RewriteState extra
s, Any
w)
  {-# INLINE return #-}
  m :: RewriteMonad extra a
m >>= :: RewriteMonad extra a
-> (a -> RewriteMonad extra b) -> RewriteMonad extra b
>>= k :: 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
$ \ r :: RewriteEnv
r s :: RewriteState extra
s w :: 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
a,s' :: RewriteState extra
s',w' :: 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
$ \_ s :: RewriteState extra
s w :: Any
w -> (RewriteState extra
s,RewriteState extra
s,Any
w)
  {-# INLINE get #-}
  put :: RewriteState extra -> RewriteMonad extra ()
put s :: 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
$ \_ _ w :: Any
w -> ((),RewriteState extra
s,Any
w)
  {-# INLINE put #-}
  state :: (RewriteState extra -> (a, RewriteState extra))
-> RewriteMonad extra a
state f :: 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
$ \_ s :: RewriteState extra
s w :: Any
w -> case RewriteState extra -> (a, RewriteState extra)
f RewriteState extra
s of (a :: a
a,s' :: 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 :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Supply (RewriteState extra) Supply
forall extra. Lens' (RewriteState extra) Supply
uniqSupply
    let (a :: Int
a,sup' :: 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 :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Supply
sup'
    Int
a Int -> RewriteMonad extra Int -> RewriteMonad extra Int
forall a b. a -> b -> b
`seq` Int -> RewriteMonad extra Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
a

instance MonadWriter Any (RewriteMonad extra) where
  writer :: (a, Any) -> RewriteMonad extra a
writer (a :: a
a,w' :: 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
$ \_ s :: RewriteState extra
s w :: 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)
forall a b. a -> b -> b
`seq` (a
a,RewriteState extra
s,Any
wt)
  {-# INLINE writer #-}
  tell :: Any -> RewriteMonad extra ()
tell w' :: 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
$ \_ s :: RewriteState extra
s w :: 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)
forall a b. a -> b -> b
`seq` ((),RewriteState extra
s,Any
wt)
  {-# INLINE tell #-}
  listen :: RewriteMonad extra a -> RewriteMonad extra (a, Any)
listen m :: 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
$ \r :: RewriteEnv
r s :: RewriteState extra
s w :: 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
a,s' :: RewriteState extra
s',w' :: 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)
forall a b. a -> b -> b
`seq` ((a
a,Any
w'),RewriteState extra
s',Any
wt)
  {-# INLINE listen #-}
  pass :: RewriteMonad extra (a, Any -> Any) -> RewriteMonad extra a
pass m :: 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
$ \r :: RewriteEnv
r s :: RewriteState extra
s w :: 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
a,f :: Any -> Any
f),s' :: RewriteState extra
s',w' :: 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)
forall a b. a -> b -> b
`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 f :: Any -> Any
f m :: 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
$ \r :: RewriteEnv
r s :: RewriteState extra
s w :: 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
a,s' :: RewriteState extra
s',w' :: 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)
forall a b. a -> b -> b
`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
$ \r :: RewriteEnv
r s :: RewriteState extra
s w :: Any
w -> (RewriteEnv
r,RewriteState extra
s,Any
w)
   {-# INLINE ask #-}
   local :: (RewriteEnv -> RewriteEnv)
-> RewriteMonad extra a -> RewriteMonad extra a
local f :: RewriteEnv -> RewriteEnv
f m :: 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
$ \r :: RewriteEnv
r s :: RewriteState extra
s w :: 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 f :: 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
$ \r :: RewriteEnv
r s :: RewriteState extra
s w :: 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 f :: 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
$ \r :: RewriteEnv
r s :: RewriteState extra
s w :: 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
a,_,_) -> 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)