Commit aa4d8a3a authored by Sven Keidel's avatar Sven Keidel

add free variables transformer

parent 52461cf5
Pipeline #14054 passed with stages
in 20 minutes and 3 seconds
......@@ -45,3 +45,10 @@ joinList1 f = proc (e,(l,s)) -> case l of
[] -> bottom -< ()
[x] -> f -< (e,(x,s))
(x:xs) -> (f -< (e,(x,s))) <> (joinList1 f -< (e,(xs,s)))
joinList1' :: (ArrowChoice c, ArrowLowerBounded c, ArrowComplete y c) => c (x,e) y -> c ([x],e) y
joinList1' f = proc (l,e) -> case l of
[] -> bottom -< ()
[x] -> f -< (x,e)
(x:xs) -> (f -< (x,e)) <> (joinList1' f -< (xs,e))
......@@ -27,66 +27,64 @@ import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
import Control.Arrow.Order
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Category
import Data.Order (Complete(..))
import Data.Identifiable
import Data.HashMap.Lazy as HM
import qualified Data.HashMap.Lazy as HM
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
type Env var addr val = (HM.HashMap var addr,HM.HashMap addr val)
type Alloc c var addr val = c (var,val,Env var addr val) addr
newtype EnvT var addr val c x y = EnvT (ConstT (c (var,val,Env var addr val) addr) (ReaderT (HM.HashMap var addr) (StateT (HM.HashMap addr val) c)) x y )
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowFail e, ArrowLowerBounded)
newtype EnvT var addr val c x y = EnvT (ConstT (Alloc c var addr val) (ReaderT (Env var addr val) c) x y )
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowFail e, ArrowComplete z, ArrowLowerBounded)
deriving instance ArrowExcept e c => ArrowExcept e (EnvT var addr val c)
runEnvT :: (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c)
=> c (var,val,Env var addr val) addr -> EnvT var addr val c x y -> c x (HM.HashMap addr val,y)
runEnvT alloc (EnvT f) =
lmap (\x -> (HM.empty,(HM.empty,x)))
(runStateT (runReaderT (runConstT alloc f)))
=> Alloc c var addr val -> EnvT var addr val c x y -> c (Env var addr val,x) y
runEnvT alloc (EnvT f) = runReaderT (runConstT alloc f)
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c) =>
ArrowEnv var val (EnvT var addr val c) where
type Join y (EnvT var addr val c) = ()
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
env <- Reader.ask -< ()
store <- State.get -< ()
(env,store) <- Reader.ask -< ()
case do { addr <- HM.lookup var env; HM.lookup addr store } of
Just val -> f -< (val,x)
Nothing -> g -< x
extend (EnvT f) = EnvT $ ConstT $ StaticT $ \alloc -> ReaderT $ StateT $ proc (store,(env,(var,val,x))) -> do
extend (EnvT f) = EnvT $ ConstT $ StaticT $ \alloc -> ReaderT $ proc ((env,store),(var,val,x)) -> do
addr <- alloc -< (var,val,(env,store))
let env' = HM.insert var addr env
let env' = HM.insert var addr env
store' = HM.insertWith () addr val store
runStateT (runReaderT (runConstT alloc f)) -< (store',(env',x))
runReaderT (runConstT alloc f) -< ((env',store'),x)
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, Profunctor c) =>
ArrowClosure var val (HM.HashMap var addr) (EnvT var addr val c) where
ask = EnvT Reader.ask
local (EnvT f) = EnvT $ Reader.local f
ask = EnvT (rmap fst Reader.ask)
local (EnvT f) = EnvT $ proc (env,x) -> do
(_,store) <- Reader.ask -< ()
Reader.local f -< ((env,store),x)
instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c, ArrowRun c) => ArrowRun (EnvT var addr val c) where
type Rep (EnvT var addr val c) x y = c (var,val,Env var addr val) addr -> Rep c x (HM.HashMap addr val,y)
type Rep (EnvT var addr val c) x y = Alloc c var addr val -> Rep c (Env var addr val,x) y
run f alloc = run (runEnvT alloc f)
instance ArrowTrans (EnvT var addr val) where
type Dom (EnvT var addr val) x y = (HM.HashMap addr val,(HM.HashMap var addr,x))
type Cod (EnvT var addr val) x y = (HM.HashMap addr val,y)
type Dom (EnvT var addr val) x y = (Env var addr val,x)
type Cod (EnvT var addr val) x y = y
lift = undefined
unlift = undefined
instance ArrowLift (EnvT var addr val) where
lift' f = EnvT (lift' (lift' (lift' f)))
lift' f = EnvT (lift' (lift' f))
instance ArrowReader r c => ArrowReader r (EnvT var addr val c) where
ask = lift' Reader.ask
......
......@@ -6,7 +6,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Abstract.Contour(CallString,ContourT,runContourT) where
module Control.Arrow.Transformer.Abstract.Contour(ContourT,runContourT,contour,CallString) where
import Prelude hiding (id,(.),lookup)
......@@ -45,6 +45,9 @@ runContourT :: (Arrow c, Profunctor c) => Int -> ContourT lab c a b -> c a b
runContourT k (ContourT (ReaderT f)) = lmap (\a -> (empty k,a)) f
{-# INLINE runContourT #-}
contour :: (Arrow c, Profunctor c) => ContourT lab c () (CallString lab)
contour = ContourT Reader.ask
instance ArrowRun c => ArrowRun (ContourT lab c) where
type Rep (ContourT lab c) x y = Int -> Rep c x y
run f i = run (runContourT i f)
......
......@@ -40,11 +40,11 @@ newtype ChaoticT a b c x y =
(ReaderT (Stack a) c)) x y)
deriving (Profunctor,Category,Arrow,ArrowChoice)
runChaoticT :: Profunctor c => ChaoticT a b c x y -> c x y
runChaoticT f = rmap snd (runChaoticT' f)
runChaoticT :: Profunctor c => ChaoticT a b c x y -> c x (HashMap a (b,Stable),y)
runChaoticT (ChaoticT f) = dimap (\a -> (empty,(M.empty,a))) (second snd) (runReaderT (runStateT (runWriterT f)))
runChaoticT' :: Profunctor c => ChaoticT a b c x y -> c x (HashMap a (b,Stable),y)
runChaoticT' (ChaoticT f) = dimap (\a -> (empty,(M.empty,a))) (second snd) (runReaderT (runStateT (runWriterT f)))
runChaoticT' :: Profunctor c => ChaoticT a b c x y -> c x y
runChaoticT' f = rmap snd (runChaoticT f)
chaotic :: (Identifiable a, LowerBounded b, Profunctor c, ArrowChoice c, ArrowApply c) => Widening b -> IterationStrategy (ChaoticT a b c) a b
chaotic widen (ChaoticT (WriterT (StateT f))) = ChaoticT $ WriterT $ StateT $ push $ proc (stack,cache,a) -> do
......@@ -92,7 +92,7 @@ chaotic widen (ChaoticT (WriterT (StateT f))) = ChaoticT $ WriterT $ StateT $ pu
local g -< (Stack (H.insert a xs),(xs,cache,a))
instance (Identifiable a, ArrowRun c) => ArrowRun (ChaoticT a b c) where
type Rep (ChaoticT a b c) x y = Rep c x y
type Rep (ChaoticT a b c) x y = Rep c x (HashMap a (b,Stable),y)
run = run . runChaoticT
instance (Identifiable a,Profunctor c,ArrowApply c) => ArrowApply (ChaoticT a b c) where app = ChaoticT (lmap (first coerce) app)
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Finite where
import Prelude hiding ((.))
import Data.Coerce
import Data.Empty
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Identifiable
import Data.Order
import Data.Profunctor
import Data.Profunctor.Unsafe
import Control.Category
import Control.Arrow
import Control.Arrow.Order
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.State
import Control.Arrow.Transformer.State
newtype FiniteT a b c x y = FiniteT (StateT (HashMap a b) c x y)
deriving (Category,Arrow,ArrowChoice,ArrowTrans,Profunctor)
runFiniteT :: Profunctor c => FiniteT a b c x y -> c x (HashMap a b,y)
runFiniteT (FiniteT f) = lmap (\x -> (empty,x)) (runStateT f)
finite :: (Identifiable a, Arrow c,Profunctor c) => IterationStrategy (FiniteT a b c) a b
finite (FiniteT f) = FiniteT $ proc a -> do
b <- f -< a
modify' (\((a,b),m) -> (b,M.insert a b m)) -< (a,b)
instance ArrowRun c => ArrowRun (FiniteT a b c) where
type Rep (FiniteT a b c) x y = Rep c x (HashMap a b,y)
run = run . runFiniteT
instance (Profunctor c, Arrow c, Complete y) => ArrowComplete y (FiniteT a b c) where
FiniteT f <> FiniteT g = FiniteT $ dimap (\x -> (x,x)) (\(y1,y2) -> y1 y2) (f *** g)
instance (Profunctor c, ArrowApply c) => ArrowApply (FiniteT a b c) where
app = FiniteT (app .# first coerce)
......@@ -10,7 +10,8 @@ module Control.Arrow.Transformer.Abstract.Fix.IterationStrategy(
IterationStrategy, trace, filter,
module Control.Arrow.Transformer.Abstract.Fix.StackWidening,
module Control.Arrow.Transformer.Abstract.Fix.Parallel,
module Control.Arrow.Transformer.Abstract.Fix.Chaotic
module Control.Arrow.Transformer.Abstract.Fix.Chaotic,
module Control.Arrow.Transformer.Abstract.Fix.Finite
) where
import Prelude hiding (pred,filter)
......@@ -20,6 +21,7 @@ import Control.Arrow.Fix
import Control.Arrow.Transformer.Abstract.Fix.StackWidening
import Control.Arrow.Transformer.Abstract.Fix.Parallel
import Control.Arrow.Transformer.Abstract.Fix.Chaotic
import Control.Arrow.Transformer.Abstract.Fix.Finite
import Data.Profunctor
import Data.Lens (Prism',getMaybe,set)
......
......@@ -87,8 +87,8 @@ instance IsCache cache a b => IsCache (Iteration cache) a b where
in ((st',b'),cache { new = new', stable = st' })
instance (ArrowRun c) => ArrowRun (ParallelT a b c) where
type Rep (ParallelT a b c) x y = Rep c x y
run = run . evalParallelT
type Rep (ParallelT a b c) x y = Rep c x (Cache a b, y)
run = run . runParallelT
{-# INLINE run #-}
type instance Fix x y (ParallelT _ _ c) = ParallelT x y c
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DerivingStrategies #-}
module Control.Arrow.Transformer.Abstract.ReachingDefinitions(
ReachingDefsT(..),
reachingDefsT,
runReachingDefsT,
runReachingDefsT',
) where
import Prelude hiding ((.),read,id)
import Control.Category
import Control.Arrow
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Fail
import Control.Arrow.Store as Store
import Control.Arrow.Environment
import Control.Arrow.Order
import Control.Arrow.Transformer.Reader
import Data.Abstract.DiscretePowerset(Pow)
import qualified Data.Abstract.DiscretePowerset as P
import Data.Identifiable
-- | Arrow transformer for a dynamic reaching definition analysis.
module Control.Arrow.Transformer.Abstract.ReachingDefinitions
( ReachingDefsT
, R.runReachingDefsT
) where
import qualified Control.Arrow.Transformer.ReachingDefinitions as R
import Data.Abstract.DiscretePowerset
import Data.Label
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype ReachingDefsT lab c x y = ReachingDefsT (ReaderT (Maybe lab) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,
ArrowState s,
ArrowEnv var val, ArrowClosure var val env,
ArrowFail e,ArrowExcept e,
ArrowLowerBounded, ArrowComplete z)
reachingDefsT :: (Arrow c,Profunctor c) => c (Maybe lab,x) y -> ReachingDefsT lab c x y
reachingDefsT = lift
{-# INLINE reachingDefsT #-}
runReachingDefsT :: (Arrow c,Profunctor c) => ReachingDefsT lab c x y -> c (Maybe lab,x) y
runReachingDefsT = unlift
{-# INLINE runReachingDefsT #-}
runReachingDefsT' :: (Arrow c,Profunctor c) => ReachingDefsT lab c x y -> c x y
runReachingDefsT' f = lmap (\x -> (Nothing,x)) (runReachingDefsT f)
{-# INLINE runReachingDefsT' #-}
instance ArrowRun c => ArrowRun (ReachingDefsT lab c) where
type Rep (ReachingDefsT lab c) x y = Rep c x y
run = run . runReachingDefsT'
instance (Identifiable var, Identifiable lab, ArrowStore var (val,Pow lab) c) => ArrowStore var val (ReachingDefsT lab c) where
type Join y (ReachingDefsT lab c) = Store.Join y c
read (ReachingDefsT f) (ReachingDefsT g) = ReachingDefsT $ read (lmap (\((v,_::Pow lab),x) -> (v,x)) f) g
write = reachingDefsT $ lmap (\(lab,(var,val)) -> (var,(val,P.fromMaybe lab))) write
type instance Fix x y (ReachingDefsT lab c) = ReachingDefsT lab (Fix x y c)
instance (HasLabel x lab, Arrow c, ArrowFix x y c) => ArrowFix x y (ReachingDefsT lab c) where
fix f = ReachingDefsT $ ReaderT $ proc (_,x) -> fix (unwrap . f . lift') -< x
where
unwrap :: HasLabel x lab => ReachingDefsT lab c x y -> c x y
unwrap f' = lmap (\x -> (Just (label x),x)) (runReachingDefsT f')
instance (ArrowApply c,Profunctor c) => ArrowApply (ReachingDefsT lab c) where
app = ReachingDefsT (app .# first coerce)
instance ArrowReader r c => ArrowReader r (ReachingDefsT lab c) where
ask = lift' Reader.ask
local f = lift $ lmap (\(m,(r,a)) -> (r,(m,a))) (Reader.local (unlift f))
type ReachingDefsT c = R.ReachingDefsT Pow Label c
......@@ -6,27 +6,27 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Concrete.Contour(CallString,ContourT,runContourT) where
module Control.Arrow.Transformer.Concrete.Contour(ContourT,runContourT) where
import Prelude hiding (id,(.),lookup)
import Prelude hiding (id,(.),lookup)
import Control.Category
import Control.Arrow
import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Trans
import Control.Category
import Control.Arrow
import Control.Arrow.Environment
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Trans
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Reader
import Data.Label
import Data.CallString
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
import Data.Empty
import Data.Label
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
-- | Records the full call string.
newtype ContourT lab c a b = ContourT (ReaderT [lab] c a b)
......@@ -35,7 +35,7 @@ newtype ContourT lab c a b = ContourT (ReaderT [lab] c a b)
-- | Runs a computation that records a the full call string of the interpreter.
runContourT :: (Arrow c, Profunctor c) => ContourT lab c a b -> c a b
runContourT (ContourT (ReaderT f)) = lmap (\a -> ([],a)) f
runContourT (ContourT (ReaderT f)) = lmap (\a -> (empty,a)) f
{-# INLINE runContourT #-}
instance ArrowRun c => ArrowRun (ContourT lab c) where
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Arrow transformer for a dynamic reaching definition analysis.
module Control.Arrow.Transformer.Concrete.ReachingDefinitions(
ReachingDefsT(..),
reachingDefsT,
runReachingDefsT,
runReachingDefsT',
) where
module Control.Arrow.Transformer.Concrete.ReachingDefinitions
( ReachingDefsT
, R.runReachingDefsT
) where
import Prelude hiding ((.),read,id)
import Control.Category
import Control.Arrow
import Control.Arrow.Environment
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Store as Store
import Control.Arrow.Trans
import Control.Arrow.Transformer.Reader
import Data.Identifiable
import qualified Control.Arrow.Transformer.ReachingDefinitions as R
import Data.Functor.Identity
import Data.Label
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype ReachingDefsT lab c x y = ReachingDefsT (ReaderT (Maybe lab) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,
ArrowFail e,ArrowExcept e,ArrowState s,ArrowEnv var val,ArrowClosure var val env)
reachingDefsT :: (Arrow c,Profunctor c) => c (Maybe lab,x) y -> ReachingDefsT lab c x y
reachingDefsT = lift
runReachingDefsT :: (Arrow c,Profunctor c) => ReachingDefsT lab c x y -> c (Maybe lab,x) y
runReachingDefsT = unlift
runReachingDefsT' :: (Arrow c,Profunctor c) => ReachingDefsT lab c x y -> c x y
runReachingDefsT' f = lmap (\x -> (Nothing,x)) (runReachingDefsT f)
instance ArrowRun c => ArrowRun (ReachingDefsT lab c) where
type Rep (ReachingDefsT lab c) x y = Rep c x y
run = run . runReachingDefsT'
{-# INLINE run #-}
instance (Identifiable var, Identifiable lab, ArrowStore var (val,Maybe lab) c) => ArrowStore var val (ReachingDefsT lab c) where
type instance Join y (ReachingDefsT lab c) = Store.Join y c
read (ReachingDefsT f) (ReachingDefsT g) = ReachingDefsT $ read (lmap (\((v,_),x) -> (v,x)) f) g
write = reachingDefsT $ lmap (\(lab,(var,val)) -> (var,(val,lab))) write
instance (HasLabel x lab, Arrow c, ArrowFix x y c) => ArrowFix x y (ReachingDefsT lab c) where
fix f = ReachingDefsT $ ReaderT $ proc (_,x) -> fix (unwrap . f . lift') -< x
where
unwrap :: HasLabel x lab => ReachingDefsT lab c x y -> c x y
unwrap f' = (Just . label &&& id) ^>> runReachingDefsT f'
instance (ArrowApply c,Profunctor c) => ArrowApply (ReachingDefsT lab c) where
app = ReachingDefsT (app .# first coerce)
instance ArrowReader r c => ArrowReader r (ReachingDefsT lab c) where
ask = lift' Reader.ask
local f = lift $ lmap (\(m,(r,a)) -> (r,(m,a))) (Reader.local (unlift f))
type instance Fix x y (ReachingDefsT lab c) = ReachingDefsT lab (Fix x y c)
type ReachingDefsT c a b = R.ReachingDefsT Identity Label c a b
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.FreeVars where
import Prelude hiding ((.),read,Maybe(..))
import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Order
import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Trans
import Control.Arrow.Writer as Writer
import Control.Arrow.Transformer.Writer
import Data.Identifiable
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
import Data.HashSet(HashSet)
import qualified Data.HashSet as H
newtype FreeVarsT var c x y = FreeVarsT (WriterT (HashSet var) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowLowerBounded,
ArrowState s, ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowConst k, ArrowRun)
runFreeVarsT :: (Arrow c, Profunctor c) => FreeVarsT var c x y -> c x y
runFreeVarsT (FreeVarsT f) = rmap snd (runWriterT f)
{-# INLINE runFreeVarsT #-}
instance (Identifiable var, ArrowEnv var val c, Profunctor c) => ArrowEnv var val (FreeVarsT var c) where
type Join y (FreeVarsT var c) = Env.Join (HashSet var,y) c
lookup (FreeVarsT f) (FreeVarsT g) = FreeVarsT $ proc (var,x) -> do
tell -< H.singleton var
Env.lookup f g -< (var,x)
extend (FreeVarsT f) = FreeVarsT $ proc (var,val,x) -> do
censor (\(var,_,_) -> H.delete var) (Env.extend f) -< (var,val,x)
instance (Identifiable var,ArrowApply c, Profunctor c) => ArrowApply (FreeVarsT var c) where
app = FreeVarsT (app .# first coerce)
type instance Fix x y (FreeVarsT var c) = FreeVarsT var (Fix (Dom (FreeVarsT var) x y) (Cod (FreeVarsT var) x y) c)
deriving instance (Identifiable var,ArrowFix x (HashSet var,y) c) => ArrowFix x y (FreeVarsT var c)
deriving instance (Identifiable var,ArrowComplete (HashSet var,y) c) => ArrowComplete y (FreeVarsT var c)
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DerivingStrategies #-}
module Control.Arrow.Transformer.ReachingDefinitions(
ReachingDefsT(..),
runReachingDefsT,
) where
import Prelude hiding ((.),read,id)
import Control.Category
import Control.Arrow
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Reader as Reader
import Control.Arrow.State
import Control.Arrow.Fail
import Control.Arrow.Store as Store
import Control.Arrow.Environment
import Control.Arrow.Order
import Control.Arrow.Transformer.Reader
import Data.Label
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
import Data.Utils
newtype ReachingDefsT (f :: * -> *) lab c x y = ReachingDefsT (ReaderT (Maybe lab) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,
ArrowState s, ArrowEnv var val, ArrowClosure var val env,
ArrowFail e,ArrowExcept e, ArrowLowerBounded, ArrowComplete z)
reachingDefsT :: (Arrow c,Profunctor c) => c (Maybe lab,x) y -> ReachingDefsT f lab c x y
reachingDefsT = lift
{-# INLINE reachingDefsT #-}
runReachingDefsT :: (Arrow c,Profunctor c) => ReachingDefsT f lab c x y -> c x y
runReachingDefsT f = lmap (\x -> (Nothing,x)) (unlift f)
{-# INLINE runReachingDefsT #-}
runReachingDefsT' :: (Arrow c,Profunctor c) => ReachingDefsT f lab c x y -> c (Maybe lab,x) y
runReachingDefsT' = unlift
{-# INLINE runReachingDefsT' #-}
instance ArrowRun c => ArrowRun (ReachingDefsT f lab c) where
type Rep (ReachingDefsT f lab c) x y = Rep c x y
run = run . runReachingDefsT
instance (ArrowStore var (val,f lab) c, IsEmpty (f lab), IsSingleton (f lab), Elem (f lab) ~ lab) =>
ArrowStore var val (ReachingDefsT f lab c) where
type Join y (ReachingDefsT f lab c) = Store.Join y c
read (ReachingDefsT f) (ReachingDefsT g) = ReachingDefsT $ read (lmap (\((v,_),x) -> (v,x)) f) g
write = reachingDefsT $ lmap (\(lab,(var,val)) -> (var,(val,fromMaybe lab))) write
type instance Fix x y (ReachingDefsT f lab c) = ReachingDefsT f lab (Fix x y c)
instance (HasLabel x lab, Arrow c, ArrowFix x y c) => ArrowFix x y (ReachingDefsT f lab c) where
fix f = ReachingDefsT $ ReaderT $ proc (_,x) -> fix (unwrap . f . lift') -< x
where
unwrap :: HasLabel x lab => ReachingDefsT f lab c x y -> c x y
unwrap g = lmap (\x -> (Just (label x),x)) (runReachingDefsT' g)
instance (ArrowApply c,Profunctor c) => ArrowApply (ReachingDefsT f lab c) where
app = ReachingDefsT (app .# first coerce)
instance ArrowReader r c => ArrowReader r (ReachingDefsT f lab c) where
ask = lift' Reader.ask
local f = lift $ lmap (\(m,(r,a)) -> (r,(m,a))) (Reader.local (unlift f))
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Arrow Transformer that can be used to define value operations:
--
-- > instance IsVal Val (ValueT Val c) where ...
--
-- ATTENTION: 'ArrowComplete' should be defined on a case by case basis.