{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Retrie.Monad
(
Retrie
, addImports
, apply
, applyWithStrategy
, applyWithUpdate
, applyWithUpdateAndStrategy
, focus
, ifChanged
, iterateR
, query
, queryWithUpdate
, topDownPrune
, getGroundTerms
, liftRWST
, runRetrie
) where
import Control.Monad.IO.Class
import Control.Monad.State.Strict
import Control.Monad.RWS
import Control.Monad.Writer.Strict
import Data.Foldable
import Retrie.Context
import Retrie.CPP
import Retrie.ExactPrint hiding (rs)
import Retrie.Fixity
import Retrie.GroundTerms
import Retrie.Query
import Retrie.Replace
import Retrie.Substitution
import Retrie.SYB
import Retrie.Types
import Retrie.Universe
data Retrie a where
Bind :: Retrie b -> (b -> Retrie a) -> Retrie a
Inst :: RetrieInstruction a -> Retrie a
Pure :: a -> Retrie a
data RetrieInstruction a where
Focus :: [GroundTerms] -> RetrieInstruction ()
Tell :: Change -> RetrieInstruction ()
IfChanged :: Retrie () -> Retrie () -> RetrieInstruction ()
Compute :: RetrieComp a -> RetrieInstruction a
type RetrieComp = RWST FixityEnv Change (CPP AnnotatedModule) IO
singleton :: RetrieInstruction a -> Retrie a
singleton :: forall a. RetrieInstruction a -> Retrie a
singleton = forall a. RetrieInstruction a -> Retrie a
Inst
liftRWST :: RetrieComp a -> Retrie a
liftRWST :: forall a. RetrieComp a -> Retrie a
liftRWST = forall a. RetrieInstruction a -> Retrie a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RetrieComp a -> RetrieInstruction a
Compute
data RetrieView a where
Return :: a -> RetrieView a
(:>>=) :: RetrieInstruction b -> (b -> Retrie a) -> RetrieView a
view :: Retrie a -> RetrieView a
view :: forall a. Retrie a -> RetrieView a
view (Pure a
x) = forall a. a -> RetrieView a
Return a
x
view (Inst RetrieInstruction a
inst) = RetrieInstruction a
inst forall b a. RetrieInstruction b -> (b -> Retrie a) -> RetrieView a
:>>= forall (m :: * -> *) a. Monad m => a -> m a
return
view (Bind (Pure b
x) b -> Retrie a
k) = forall a. Retrie a -> RetrieView a
view (b -> Retrie a
k b
x)
view (Bind (Inst RetrieInstruction b
inst) b -> Retrie a
k) = RetrieInstruction b
inst forall b a. RetrieInstruction b -> (b -> Retrie a) -> RetrieView a
:>>= b -> Retrie a
k
view (Bind (Bind Retrie b
m b -> Retrie b
k1) b -> Retrie a
k2) = forall a. Retrie a -> RetrieView a
view (forall b a. Retrie b -> (b -> Retrie a) -> Retrie a
Bind Retrie b
m (b -> Retrie b
k1 forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> b -> Retrie a
k2))
instance Functor Retrie where
fmap :: forall a b. (a -> b) -> Retrie a -> Retrie b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative Retrie where
pure :: forall a. a -> Retrie a
pure = forall a. a -> Retrie a
Pure
<*> :: forall a b. Retrie (a -> b) -> Retrie a -> Retrie b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad Retrie where
return :: forall a. a -> Retrie a
return = forall a. a -> Retrie a
Pure
>>= :: forall b a. Retrie b -> (b -> Retrie a) -> Retrie a
(>>=) = forall b a. Retrie b -> (b -> Retrie a) -> Retrie a
Bind
instance MonadIO Retrie where
liftIO :: forall a. IO a -> Retrie a
liftIO = forall a. RetrieInstruction a -> Retrie a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RetrieComp a -> RetrieInstruction a
Compute forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
runRetrie
:: FixityEnv
-> Retrie a
-> CPP AnnotatedModule
-> IO (a, CPP AnnotatedModule, Change)
runRetrie :: forall a.
FixityEnv
-> Retrie a
-> CPP AnnotatedModule
-> IO (a, CPP AnnotatedModule, Change)
runRetrie FixityEnv
fixities Retrie a
retrie = forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (forall a. Retrie a -> RetrieComp a
getComp Retrie a
retrie) FixityEnv
fixities
getGroundTerms :: Retrie a -> [GroundTerms]
getGroundTerms :: forall a. Retrie a -> [GroundTerms]
getGroundTerms = forall a. RetrieView a -> [GroundTerms]
eval forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Retrie a -> RetrieView a
view
where
eval :: RetrieView a -> [GroundTerms]
eval :: forall a. RetrieView a -> [GroundTerms]
eval Return{} = []
eval (RetrieInstruction b
inst :>>= b -> Retrie a
k) =
case RetrieInstruction b
inst of
Focus [GroundTerms]
gts -> [GroundTerms]
gts
Tell Change
_ -> forall a. Retrie a -> [GroundTerms]
getGroundTerms forall a b. (a -> b) -> a -> b
$ b -> Retrie a
k ()
IfChanged Retrie ()
retrie1 Retrie ()
retrie2
| gts :: [GroundTerms]
gts@(GroundTerms
_:[GroundTerms]
_) <- forall a. Retrie a -> [GroundTerms]
getGroundTerms Retrie ()
retrie1 -> [GroundTerms]
gts
| gts :: [GroundTerms]
gts@(GroundTerms
_:[GroundTerms]
_) <- forall a. Retrie a -> [GroundTerms]
getGroundTerms Retrie ()
retrie2 -> [GroundTerms]
gts
| Bool
otherwise -> forall a. Retrie a -> [GroundTerms]
getGroundTerms forall a b. (a -> b) -> a -> b
$ b -> Retrie a
k ()
Compute RetrieComp b
_ -> []
getComp :: Retrie a -> RetrieComp a
getComp :: forall a. Retrie a -> RetrieComp a
getComp = forall {a}.
RetrieView a -> RWST FixityEnv Change (CPP AnnotatedModule) IO a
eval forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Retrie a -> RetrieView a
view
where
eval :: RetrieView a -> RWST FixityEnv Change (CPP AnnotatedModule) IO a
eval (Return a
x) = forall (m :: * -> *) a. Monad m => a -> m a
return a
x
eval (RetrieInstruction b
inst :>>= b -> Retrie a
k) = forall {a}. RetrieInstruction a -> RetrieComp a
evalInst RetrieInstruction b
inst forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Retrie a -> RetrieComp a
getComp forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Retrie a
k
evalInst :: RetrieInstruction a -> RetrieComp a
evalInst (Focus [GroundTerms]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
evalInst (Tell Change
c) = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Change
c
evalInst (IfChanged Retrie ()
r1 Retrie ()
r2) = RetrieComp () -> RetrieComp () -> RetrieComp ()
ifChangedComp (forall a. Retrie a -> RetrieComp a
getComp Retrie ()
r1) (forall a. Retrie a -> RetrieComp a
getComp Retrie ()
r2)
evalInst (Compute RetrieComp a
m) = RetrieComp a
m
focus :: Data k => [Query k v] -> Retrie ()
focus :: forall k v. Data k => [Query k v] -> Retrie ()
focus [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
focus [Query k v]
qs = forall a. RetrieInstruction a -> Retrie a
singleton forall a b. (a -> b) -> a -> b
$ [GroundTerms] -> RetrieInstruction ()
Focus forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall k v. Data k => Query k v -> GroundTerms
groundTerms [Query k v]
qs
apply :: [Rewrite Universe] -> Retrie ()
apply :: [Rewrite Universe] -> Retrie ()
apply = ContextUpdater
-> Strategy (TransformT (WriterT Change IO))
-> [Rewrite Universe]
-> Retrie ()
applyWithUpdateAndStrategy ContextUpdater
updateContext forall (m :: * -> *).
Monad m =>
Strategy (TransformT (WriterT Change m))
topDownPrune
applyWithUpdate
:: ContextUpdater -> [Rewrite Universe] -> Retrie ()
applyWithUpdate :: ContextUpdater -> [Rewrite Universe] -> Retrie ()
applyWithUpdate ContextUpdater
updCtxt = ContextUpdater
-> Strategy (TransformT (WriterT Change IO))
-> [Rewrite Universe]
-> Retrie ()
applyWithUpdateAndStrategy ContextUpdater
updCtxt forall (m :: * -> *).
Monad m =>
Strategy (TransformT (WriterT Change m))
topDownPrune
applyWithStrategy
:: Strategy (TransformT (WriterT Change IO))
-> [Rewrite Universe]
-> Retrie ()
applyWithStrategy :: Strategy (TransformT (WriterT Change IO))
-> [Rewrite Universe] -> Retrie ()
applyWithStrategy = ContextUpdater
-> Strategy (TransformT (WriterT Change IO))
-> [Rewrite Universe]
-> Retrie ()
applyWithUpdateAndStrategy ContextUpdater
updateContext
applyWithUpdateAndStrategy
:: ContextUpdater
-> Strategy (TransformT (WriterT Change IO))
-> [Rewrite Universe]
-> Retrie ()
applyWithUpdateAndStrategy :: ContextUpdater
-> Strategy (TransformT (WriterT Change IO))
-> [Rewrite Universe]
-> Retrie ()
applyWithUpdateAndStrategy ContextUpdater
_ Strategy (TransformT (WriterT Change IO))
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
applyWithUpdateAndStrategy ContextUpdater
updCtxt Strategy (TransformT (WriterT Change IO))
strategy [Rewrite Universe]
rrs = do
forall k v. Data k => [Query k v] -> Retrie ()
focus [Rewrite Universe]
rrs
forall a. RetrieInstruction a -> Retrie a
singleton forall a b. (a -> b) -> a -> b
$ forall a. RetrieComp a -> RetrieInstruction a
Compute forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r s w.
Monad m =>
(r -> s -> WriterT w m s) -> RWST r w s m ()
rs forall a b. (a -> b) -> a -> b
$ \ FixityEnv
fixityEnv ->
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) c.
Monad m =>
Strategy m
-> GenericQ Bool -> GenericCU m c -> GenericMC m c -> GenericMC m c
everywhereMWithContextBut Strategy (TransformT (WriterT Change IO))
strategy
(forall a b. a -> b -> a
const Bool
False) ContextUpdater
updCtxt forall a (m :: * -> *).
(Data a, MonadIO m) =>
Context -> a -> TransformT (WriterT Change m) a
replace (FixityEnv -> Rewriter -> Rewriter -> Context
emptyContext FixityEnv
fixityEnv Rewriter
m Rewriter
d)
where
m :: Rewriter
m = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall ast. Matchable ast => Rewrite ast -> Rewriter
mkRewriter [Rewrite Universe]
rrs
d :: Rewriter
d = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall ast. Matchable ast => Rewrite ast -> Rewriter
mkRewriter forall a b. (a -> b) -> a -> b
$ forall ast. [Rewrite ast] -> [Rewrite ast]
rewritesWithDependents [Rewrite Universe]
rrs
query :: [Query Universe v] -> Retrie [(Context, Substitution, v)]
query :: forall v. [Query Universe v] -> Retrie [(Context, Substitution, v)]
query = forall v.
ContextUpdater
-> [Query Universe v] -> Retrie [(Context, Substitution, v)]
queryWithUpdate ContextUpdater
updateContext
queryWithUpdate
:: ContextUpdater
-> [Query Universe v]
-> Retrie [(Context, Substitution, v)]
queryWithUpdate :: forall v.
ContextUpdater
-> [Query Universe v] -> Retrie [(Context, Substitution, v)]
queryWithUpdate ContextUpdater
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
queryWithUpdate ContextUpdater
updCtxt [Query Universe v]
qs = do
forall k v. Data k => [Query k v] -> Retrie ()
focus [Query Universe v]
qs
forall a. RetrieInstruction a -> Retrie a
singleton forall a b. (a -> b) -> a -> b
$ forall a. RetrieComp a -> RetrieInstruction a
Compute forall a b. (a -> b) -> a -> b
$ do
FixityEnv
fixityEnv <- forall r (m :: * -> *). MonadReader r m => m r
ask
CPP AnnotatedModule
cpp <- forall s (m :: * -> *). MonadState s m => m s
get
[[(Context, Substitution, v)]]
results <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList CPP AnnotatedModule
cpp) forall a b. (a -> b) -> a -> b
$ \AnnotatedModule
modl -> do
Annotated [(Context, Substitution, v)]
annotatedResults <- forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA AnnotatedModule
modl forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) c r.
(Monad m, Monoid r) =>
GenericQ Bool
-> GenericCU m c -> GenericMCQ m c r -> GenericMCQ m c r
everythingMWithContextBut
(forall a b. a -> b -> a
const Bool
False)
ContextUpdater
updCtxt
(forall a v.
Typeable a =>
Matcher v
-> Context -> a -> TransformT IO [(Context, Substitution, v)]
genericQ Matcher v
matcher)
(FixityEnv -> Rewriter -> Rewriter -> Context
emptyContext FixityEnv
fixityEnv forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall ast. Annotated ast -> ast
astA Annotated [(Context, Substitution, v)]
annotatedResults)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Context, Substitution, v)]]
results
where
matcher :: Matcher v
matcher = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall ast v. Matchable ast => Query ast v -> Matcher v
mkMatcher [Query Universe v]
qs
ifChanged :: Retrie () -> Retrie () -> Retrie ()
ifChanged :: Retrie () -> Retrie () -> Retrie ()
ifChanged Retrie ()
r1 Retrie ()
r2 = forall a. RetrieInstruction a -> Retrie a
singleton forall a b. (a -> b) -> a -> b
$ Retrie () -> Retrie () -> RetrieInstruction ()
IfChanged Retrie ()
r1 Retrie ()
r2
ifChangedComp :: RetrieComp () -> RetrieComp () -> RetrieComp ()
ifChangedComp :: RetrieComp () -> RetrieComp () -> RetrieComp ()
ifChangedComp RetrieComp ()
r1 RetrieComp ()
r2 = do
(()
_, Change
c) <- forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen RetrieComp ()
r1
case Change
c of
Change{} -> RetrieComp ()
r2
Change
NoChange -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
iterateR :: Int -> Retrie () -> Retrie ()
iterateR :: Int -> Retrie () -> Retrie ()
iterateR Int
n Retrie ()
r = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ Retrie () -> Retrie () -> Retrie ()
ifChanged Retrie ()
r forall a b. (a -> b) -> a -> b
$ Int -> Retrie () -> Retrie ()
iterateR (Int
nforall a. Num a => a -> a -> a
-Int
1) Retrie ()
r
addImports :: AnnotatedImports -> Retrie ()
addImports :: AnnotatedImports -> Retrie ()
addImports AnnotatedImports
imports = forall a. RetrieInstruction a -> Retrie a
singleton forall a b. (a -> b) -> a -> b
$ Change -> RetrieInstruction ()
Tell forall a b. (a -> b) -> a -> b
$ [Replacement] -> [AnnotatedImports] -> Change
Change [] [AnnotatedImports
imports]
topDownPrune :: Monad m => Strategy (TransformT (WriterT Change m))
topDownPrune :: forall (m :: * -> *).
Monad m =>
Strategy (TransformT (WriterT Change m))
topDownPrune a -> TransformT (WriterT Change m) a
p a -> TransformT (WriterT Change m) a
cs a
x = do
(a
p', Change
c) <- forall (m :: * -> *) w a.
(Monad m, Monoid w) =>
TransformT (WriterT w m) a -> TransformT (WriterT w m) (a, w)
listenTransformT (a -> TransformT (WriterT Change m) a
p a
x)
case Change
c of
Change{} -> forall (m :: * -> *) a. Monad m => a -> m a
return a
p'
Change
NoChange -> a -> TransformT (WriterT Change m) a
cs a
x
listenTransformT
:: (Monad m, Monoid w)
=> TransformT (WriterT w m) a -> TransformT (WriterT w m) (a, w)
listenTransformT :: forall (m :: * -> *) w a.
(Monad m, Monoid w) =>
TransformT (WriterT w m) a -> TransformT (WriterT w m) (a, w)
listenTransformT (TransformT RWST () [String] Int (WriterT w m) a
rwst) =
forall (m :: * -> *) a. RWST () [String] Int m a -> TransformT m a
TransformT forall a b. (a -> b) -> a -> b
$ forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWST forall a b. (a -> b) -> a -> b
$ \ ()
r Int
s -> do
((a
x,Int
y,[String]
z),w
w) <- forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen forall a b. (a -> b) -> a -> b
$ forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST RWST () [String] Int (WriterT w m) a
rwst ()
r Int
s
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
x,w
w),Int
y,[String]
z)
rs :: Monad m => (r -> s -> WriterT w m s) -> RWST r w s m ()
rs :: forall (m :: * -> *) r s w.
Monad m =>
(r -> s -> WriterT w m s) -> RWST r w s m ()
rs r -> s -> WriterT w m s
f = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWST forall a b. (a -> b) -> a -> b
$ \ r
r s
s -> do
(s
s', w
w) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (r -> s -> WriterT w m s
f r
r s
s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), s
s', w
w)