Commit 702cf84a authored by Sven Keidel's avatar Sven Keidel

repair FixT

parent 0b136107
......@@ -23,5 +23,5 @@ type instance Fix x y (->) = (->)
instance ArrowFix x y (->) where
fix f = f (fix f)
liftFix :: (ArrowFix (Dom t x y) (Cod t x y) c,ArrowTrans t) => (t c x y -> t c x y) -> t c x y
liftFix :: (Arrow c, Profunctor c, ArrowFix (Dom t x y) (Cod t x y) c,ArrowTrans t) => (t c x y -> t c x y) -> t c x y
liftFix f = lift $ fix (unlift . f . lift)
......@@ -14,5 +14,3 @@ class ArrowTrans t where
lift :: (Arrow c, Profunctor c) => c (Dom t x y) (Cod t x y) -> t c x y
unlift :: (Arrow c, Profunctor c) => t c x y -> c (Dom t x y) (Cod t x y)
type family Rep c x y
......@@ -14,7 +14,6 @@
module Control.Arrow.Transformer.Abstract.Fixpoint(Fix,FixT,runFixT,runFixT',runFixT'',liftFixT) where
import Prelude hiding (id,(.),lookup)
import qualified Data.Function as F
import Control.Arrow
import Control.Arrow.Fix
......@@ -75,10 +74,12 @@ import Text.Printf
-- 'Reader Env (State Store (LeastFix Stack (Store,(Env,Expr)) (Store)))'
type Cache a b = Map a (Terminating b)
newtype FixT s a b c x y = FixT (StackT s a (MemoizeT a b c) x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTerminating,ArrowFix a b,ArrowJoin)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTerminating,ArrowJoin)
type instance Fix x y (FixT s () () c) = FixT s x y c
deriving instance (Identifiable x,PreOrd y,ArrowApply c,ArrowChoice c,Profunctor c, ArrowFix (Cache x y, (Cache x y, (s x,x))) (Cache x y,Terminating y) c) => ArrowFix x y (FixT s x y c)
runFixT :: (Complete b, ArrowChoice c, Profunctor c) => FixT SW.Unit a b c x y -> c x (Terminating y)
runFixT f = runFixT' SW.finite W.finite f
......@@ -87,16 +88,12 @@ runFixT' sw w f = rmap snd (runFixT'' sw w f)
runFixT'' :: (Monoid (s a),ArrowChoice c, Profunctor c) => StackWidening s a -> Widening b -> FixT s a b c x y -> c x (Map a (Terminating b), Terminating y)
runFixT'' sw w (FixT f) =
runMemoizeT w
(runStackT (sw,mempty) f)
instance ArrowLift (FixT s a b) where
lift' f = FixT (stackT (const (lift' f)))
runMemoizeT w (runStackT (sw,mempty) f)
liftFixT :: (Arrow c, Profunctor c) => c x y -> FixT s a b c x y
liftFixT = lift'
liftFixT :: (ArrowChoice c, Profunctor c) => c x y -> FixT s a b c x y
liftFixT = FixT . lift' . MemoizeT . lift' . lift' . lift' . lift'
newtype MemoizeT a b c x y = MemoizeT (ConstT (Widening b) (ReaderT (Cache a b) (TerminatingT (StateT (Cache a b) c))) x y)
newtype MemoizeT a b c x y = MemoizeT { unMemoizeT :: ConstT (Widening b) (ReaderT (Cache a b) (TerminatingT (StateT (Cache a b) c))) x y}
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTerminating)
runMemoizeT :: (ArrowChoice c, Profunctor c) => Widening b -> MemoizeT a b c x y -> c x (Map a (Terminating b), Terminating y)
......@@ -107,19 +104,15 @@ runMemoizeT w (MemoizeT f) =
(runReaderT
(runConstT w f)))
instance ArrowLift (MemoizeT a b) where
lift' f = MemoizeT (ConstT (StaticT (const (ReaderT (TerminatingT (StateT (lmap snd (second (rmap Terminating f)))))))))
#ifndef TRACE
instance (Identifiable x, PreOrd y, ArrowChoice c, ArrowApply c, Profunctor c) => ArrowFix x y (MemoizeT x y c) where
instance (Identifiable x, PreOrd y, ArrowChoice c, ArrowApply c, Profunctor c, ArrowFix (Cache x y, (Cache x y, (s,x))) (Cache x y,Terminating y) c) => ArrowFix (s,x) y (MemoizeT x y c) where
fix f = proc x -> do
old <- getCache -< ()
-- reset the current fixpoint cache
setCache -< bottom
-- recompute the fixpoint cache by calling 'f' and memoize its results.
y <- localOldCache (F.fix (memoize . f)) -< (old,x)
y <- localOldCache (MemoizeT (fix (unMemoizeT . memoize . f . MemoizeT))) -< (old,x)
new <- getCache -< ()
......@@ -135,8 +128,8 @@ instance (Identifiable x, PreOrd y, ArrowChoice c, ArrowApply c, Profunctor c) =
-- | Memoizes the results of the interpreter function. In case a value
-- has been computed before, the cached value is returned and will not
-- be recomputed.
memoize :: (Identifiable x, PreOrd y, ArrowChoice c, Profunctor c) => MemoizeT x y c x y -> MemoizeT x y c x y
memoize f = proc x -> do
memoize :: (Identifiable x, PreOrd y, ArrowChoice c, Profunctor c) => MemoizeT x y c (s,x) y -> MemoizeT x y c (s,x) y
memoize f = proc (s,x) -> do
newCache <- getCache -< ()
case M.unsafeLookup x newCache of
-- In case the input was in the fixpoint cache, short-cut
......@@ -150,7 +143,7 @@ memoize f = proc x -> do
oldCache <- getOldCache -< ()
setCache -< M.insert x (fromMaybe bottom (M.unsafeLookup x oldCache)) newCache
y <- catchTerminating f -< x
y <- catchTerminating f -< (s,x)
(widening, newCache') <- (getWidening &&& getCache) -< ()
......@@ -190,33 +183,6 @@ memoize f = proc x -> do
y' = fromJust (M.unsafeLookup x newCache'')
setCache -< newCache''
throwTerminating -< trace (printf "RET: %s -> %s" (show x) (show y')) y'
-- instance (Show x, Show y, Identifiable x, PreOrd y, ArrowChoice c) => ArrowFix x y (FixT s x y c) where
-- fix f = proc x -> do
-- old <- getCache -< ()
-- setOutCache -< bottom
-- y <- localInCache (F.fix (memoize . f)) -< trace "----- ITERATION -----" $ (old,x)
-- new <- getOutCache -< ()
-- if (new ⊑ old)
-- then returnA -< y
-- else fix f -< x
-- memoize :: (Show x, Show y, Identifiable x, PreOrd y, ArrowChoice c) => FixT s x y c x y -> FixT s x y c x y
-- memoize (FixT f) = FixT $ \(stackWidening,widening) -> proc (((stack,inCache), outCache),x) -> do
-- case M.unsafeLookup x outCache of
-- Just y -> returnA -< trace (printf "HIT: %s -> %s" (show x) (show y))
-- (outCache,y)
-- Nothing -> do
-- let yOld = fromMaybe bottom (M.unsafeLookup x inCache)
-- outCache' = M.insert x yOld outCache
-- (x',stack') = runState (stackWidening x) stack
-- (outCache'',y) <- f (stackWidening,widening) -< trace (printf "CALL: %s" (show x')) (((stack',inCache), outCache'),x')
-- let outCache''' = M.unsafeInsertWith (flip (T.widening widening)) x' y outCache''
-- y' = fromJust (M.unsafeLookup x' outCache''')
-- returnA -< trace (printf "CACHE: %s := (%s -> %s)\n" (show x) (show y) (show y') ++
-- printf "RET: %s -> %s" (show x') (show y'))
-- (M.unsafeInsertWith (flip (T.widening widening)) x y outCache'',y')
#endif
getWidening :: (ArrowChoice c, Profunctor c) => MemoizeT x y c () (Widening y)
......@@ -231,7 +197,7 @@ getCache = MemoizeT get
setCache :: (ArrowChoice c, Profunctor c) => MemoizeT x y c (Map x (Terminating y)) ()
setCache = MemoizeT put
localOldCache :: (ArrowChoice c, Profunctor c) => MemoizeT x y c x y -> MemoizeT x y c (Map x (Terminating y),x) y
localOldCache :: (ArrowChoice c, Profunctor c) => MemoizeT a b c x y -> MemoizeT a b c (Map a (Terminating b),x) y
localOldCache (MemoizeT f) = MemoizeT (local f)
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (FixT s a b c) where app = FixT $ lmap (\(FixT f,x) -> (f,x)) app
......@@ -243,16 +209,17 @@ instance (Identifiable a, ArrowJoin c, ArrowChoice c) => ArrowJoin (MemoizeT a b
y' <- catchTerminating g -< x
throwTerminating -< T.widening lub y y'
instance (Identifiable a,Complete y,ArrowJoin c, ArrowChoice c, PreOrd (Underlying a b c x y)) => Complete (MemoizeT a b c x y) where
type Underlying1 a b c x y = (c ((Map a (Terminating b), (Map a (Terminating b), x))) (Map a (Terminating b), Terminating y))
instance (Identifiable a,Complete y,ArrowJoin c, ArrowChoice c, PreOrd (Underlying1 a b c x y)) => Complete (MemoizeT a b c x y) where
f g = joinWith () f g
type Underlying a b c x y = (c (Map a (Terminating b), (Map a (Terminating b), x)) (Map a (Terminating b), Terminating y))
deriving instance PreOrd (Underlying a b c x y) => PreOrd (FixT s a b c x y)
deriving instance (Identifiable a, Complete y, ArrowJoin c, ArrowChoice c, PreOrd (Underlying a b c x y)) => Complete (FixT s a b c x y)
deriving instance CoComplete (Underlying a b c x y) => CoComplete (FixT s a b c x y)
deriving instance LowerBounded (Underlying a b c x y) => LowerBounded (FixT s a b c x y)
deriving instance UpperBounded (Underlying a b c x y) => UpperBounded (FixT s a b c x y)
deriving instance PreOrd (Underlying a b c x y) => PreOrd (MemoizeT a b c x y)
deriving instance CoComplete (Underlying a b c x y) => CoComplete (MemoizeT a b c x y)
deriving instance LowerBounded (Underlying a b c x y) => LowerBounded (MemoizeT a b c x y)
deriving instance UpperBounded (Underlying a b c x y) => UpperBounded (MemoizeT a b c x y)
deriving instance PreOrd (Underlying1 a b c x y) => PreOrd (MemoizeT a b c x y)
deriving instance CoComplete (Underlying1 a b c x y) => CoComplete (MemoizeT a b c x y)
deriving instance LowerBounded (Underlying1 a b c x y) => LowerBounded (MemoizeT a b c x y)
deriving instance UpperBounded (Underlying1 a b c x y) => UpperBounded (MemoizeT a b c x y)
type Underlying2 s a b c x y = (c ((Map a (Terminating b), (Map a (Terminating b), (s a,x)))) (Map a (Terminating b), Terminating y))
deriving instance PreOrd (Underlying2 s a b c x y) => PreOrd (FixT s a b c x y)
deriving instance (Identifiable a, Complete y, ArrowJoin c, ArrowChoice c, PreOrd (Underlying2 s a b c x y)) => Complete (FixT s a b c x y)
deriving instance CoComplete (Underlying2 s a b c x y) => CoComplete (FixT s a b c x y)
deriving instance LowerBounded (Underlying2 s a b c x y) => LowerBounded (FixT s a b c x y)
deriving instance UpperBounded (Underlying2 s a b c x y) => UpperBounded (FixT s a b c x y)
{-# LANGUAGE Arrows #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Stack(StackT(..),runStackT,runStackT',stackT) where
import Prelude hiding ((.))
......@@ -13,10 +16,12 @@ import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.State
import Control.Arrow.Reader
import Control.Arrow.Const
import Control.Arrow.Abstract.Join
import Control.Arrow.Abstract.Terminating
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
import Control.Arrow.Transformer.Reader
import qualified Control.Monad.State as M
......@@ -24,25 +29,37 @@ import Data.Order
import Data.Profunctor
import Data.Abstract.StackWidening (StackWidening)
newtype StackT s a c x y = StackT (ConstT (StackWidening s a,s a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowLift,ArrowJoin,
ArrowState r,ArrowReader r,ArrowTerminating,
PreOrd,Complete,CoComplete,LowerBounded,UpperBounded)
instance (ArrowApply c,Profunctor c) => ArrowApply (StackT s a c) where
app = StackT (lmap (\(StackT f,x) -> (f,x)) app)
newtype StackT s a c x y = StackT { unStackT :: ConstT (StackWidening s a) (ReaderT (s a) c) x y }
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowJoin, ArrowState r,ArrowTerminating)
runStackT :: Arrow c => (StackWidening s a,s a) -> StackT s a c x y -> c x y
runStackT s (StackT f) = runConstT s f
runStackT :: (Arrow c, Profunctor c) => (StackWidening s a,s a) -> StackT s a c x y -> c x y
runStackT (w,s) (StackT f) = lmap (s,) (runReaderT (runConstT w f))
runStackT' :: (Arrow c, Monoid (s a)) => StackWidening s a -> StackT s a c x y -> c x y
runStackT' :: (Arrow c, Profunctor c, Monoid (s a)) => StackWidening s a -> StackT s a c x y -> c x y
runStackT' s = runStackT (s,mempty)
stackT :: ((StackWidening s a,s a) -> c x y) -> StackT s a c x y
stackT f = StackT $ ConstT $ StaticT $ f
stackT :: (StackWidening s a -> c (s a,x) y) -> StackT s a c x y
stackT f = StackT $ ConstT $ StaticT $ \w -> ReaderT (f w)
type instance Fix x y (StackT s () c) = StackT s x (Fix x y c)
instance (ArrowApply c, ArrowFix x y c) => ArrowFix x y (StackT s x c) where
fix f = stackT $ \(stackWidening,stack) -> proc x -> do
let (x',stack') = M.runState (stackWidening x) stack
fix (runStackT (stackWidening,stack') . f . lift') -<< x'
instance (Profunctor c,ArrowFix (s x,x) y c) => ArrowFix x y (StackT s x c) where
fix f = StackT $ fix (unStackT . widen . f . StackT)
where
widen :: (Arrow c, Profunctor c) => StackT s x c x y -> StackT s x c x y
widen (StackT f') = proc x -> do
stackWiden <- StackT askConst -< ()
stack <- StackT ask -< ()
let (x',stack') = M.runState (stackWiden x) stack
StackT (local f') -< (stack',x')
instance (ArrowApply c,Profunctor c) => ArrowApply (StackT s a c) where
app = StackT (lmap (\(StackT f,x) -> (f,x)) app)
instance ArrowLift (StackT s a) where
lift' = StackT . lift' . lift'
deriving instance PreOrd (c (s a,x) y) => PreOrd (StackT s a c x y)
deriving instance Complete (c (s a,x) y) => Complete (StackT s a c x y)
deriving instance CoComplete (c (s a,x) y) => CoComplete (StackT s a c x y)
deriving instance LowerBounded (c (s a,x) y) => LowerBounded (StackT s a c x y)
deriving instance UpperBounded (c (s a,x) y) => UpperBounded (StackT s a c x y)
......@@ -33,7 +33,7 @@ import Control.Arrow.Fix
newtype EnvT var val c x y = EnvT (ReaderT (HashMap var val) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowLift,ArrowTrans,
ArrowFail e,ArrowExcept e,ArrowState s,ArrowConst r,
ArrowStore var val)
ArrowStore var' val')
runEnvT :: (Arrow c) => EnvT var val c x y -> c (HashMap var val,x) y
runEnvT (EnvT (ReaderT f)) = f
......
......@@ -43,6 +43,9 @@ newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y)
runConstT :: r -> ConstT r c x y -> c x y
runConstT r (ConstT (StaticT f)) = f r
constT :: (r -> c x y) -> ConstT r c x y
constT f = ConstT (StaticT f)
instance (Arrow c, Profunctor c) => ArrowConst r (ConstT r c) where
askConst = ConstT $ StaticT $ \r -> arr (const r)
......
......@@ -17,6 +17,7 @@ import Data.Identifiable
import Data.Monoidal
import Data.Maybe
import Data.Abstract.Widening(Widening)
import Debug.Trace
-- | A stack widening operator (▽ :: s -> a -> (s,a)) follows the same
-- idea as a regular widening operator, but does not have the
......@@ -56,6 +57,9 @@ instance Monoid (Stack a) where
stack :: StackWidening Stack a -> StackWidening Stack a
stack f x = state $ \s@(Stack n st) -> let x' = evalState (f x) s in (x',Stack (n+1) (x':st))
traceStack :: Show a => StackWidening Stack a -> StackWidening Stack a
traceStack f x = state $ \s@(Stack n st) -> let x' = evalState (f x) s in traceShow x' (x',Stack (n+1) (x':st))
-- | Return the same elements until the specified maximum stack size
-- is reached, then call the fallback widening.
maxSize :: Int -> StackWidening Stack a -> StackWidening Stack a
......
......@@ -14,6 +14,7 @@ import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Transformer.Abstract.Fixpoint
import Control.Arrow.Transformer.Abstract.Failure
import Control.Arrow.Transformer.Abstract.Stack
import Control.Arrow.Transformer.State
import Control.Arrow.Fail
import Control.Arrow.State
......@@ -32,6 +33,7 @@ import qualified Data.Abstract.StackWidening as SW
import Data.Order
import Data.Hashable
import Data.Profunctor
import GHC.Generics
......@@ -40,7 +42,7 @@ import Test.Hspec
main :: IO ()
main = hspec spec
type Cache s x y = FixT s x y (->) x y
type PureFix s x y = FixT s x y (->) x y
type ErrorFix s x y = Fix x y (FailureT () (FixT s () () (->))) x y
type StateFix s x y = Fix x y (StateT IV (FixT s () () (->))) x y
type IV = Interval (InfiniteNumber Int)
......@@ -48,7 +50,7 @@ type IV = Interval (InfiniteNumber Int)
spec :: Spec
spec = do
describe "the analysis of the fibonacci numbers" $
let fib :: Cache s IV IV
let fib :: PureFix s IV IV
fib = fix $ \f ->
ifLowerThan 0
(proc _ -> returnA -< I.Interval 0 0)
......@@ -63,7 +65,7 @@ spec = do
runFixT' SW.finite I.widening fib (I.Interval 0 Infinity) `shouldBe` return (I.Interval 0 Infinity)
describe "the analysis of the factorial function" $
let fact :: Cache s IV IV
let fact :: PureFix s IV IV
fact = fix $ \f -> proc n -> do
ifLowerThan 1 (proc _ -> returnA -< I.Interval 1 1)
(proc n -> do {x <- f -< (n-I.Interval 1 1); returnA -< n * x}) -< n
......@@ -71,7 +73,7 @@ spec = do
runFixT' SW.finite I.widening fact top `shouldBe` return (I.Interval 1 Infinity)
describe "the even and odd functions" $
let evenOdd :: Cache s (EvenOdd,IV) Bool
let evenOdd :: PureFix s (EvenOdd,IV) Bool
evenOdd = fix $ \f -> proc (e,x) -> case e of
Even -> ifLowerThan 0 (proc _ -> returnA -< true)
(ifLowerThan 1 (proc _ -> returnA -< false)
......@@ -83,7 +85,7 @@ spec = do
runFixT' SW.finite W.finite evenOdd (Even,I.Interval 0 Infinity) `shouldBe` top
describe "the ackermann function" $
let ackermann :: Cache s (IV,IV) IV
let ackermann :: PureFix s (IV,IV) IV
ackermann = fix $ \f -> proc (m,n) ->
ifLowerThan 0
(proc _ -> returnA -< n + I.Interval 1 1)
......@@ -97,7 +99,7 @@ spec = do
`shouldBe` return (I.Interval 1 Infinity)
describe "the analyis of a diverging program" $
let diverge :: Cache s Int Sign
let diverge :: PureFix s Int Sign
diverge = fix $ \f -> proc n -> case n of
0 -> f -< 0
_ -> f -< (n-1)
......@@ -116,21 +118,31 @@ spec = do
describe "the analysis of a stateful program" $
let timesTwo :: StateFix s IV ()
timesTwo = fix $ \f -> proc n -> case n of
I.Interval 0 0 -> returnA -< ()
0 -> returnA -< ()
_ -> do
s <- get -< ()
put -< s + I.Interval 1 1
put -< s + 1
f -< n-1
s' <- get -< ()
put -< s'+ I.Interval 1 1
put -< s'+ 1
in it "should cache the state of the program" $
runFixT'' SW.finite W.finite (runStateT timesTwo) (0,5) `shouldBe`
(S.fromList [((fromIntegral n,5-fromIntegral n),
return (10-fromIntegral n,())) | n <- [0..5::Int]],
return (10,()))
describe "stack (maxSize 5 top)" $
let loop10 :: PureFix s IV IV
loop10 = fix $ \f -> proc x ->
if 10 x
then returnA -< 10
else f -< (x+1)
in it "should terminate after 5 iterations" $
fst (runFixT'' (SW.stack (SW.maxSize 5 SW.topOut)) I.widening loop10 0)
`shouldBe` (S.fromList [ (fromIntegral n,Terminating 10) | n <- [0..6::Int]])
where
ifLowerThan :: (Num n, Ord n, ArrowChoice c, Complete (c (Interval n, Interval n) x)) => n -> c (Interval n) x -> c (Interval n) x -> c (Interval n) x
ifLowerThan :: (Num n, Ord n, ArrowChoice c, Profunctor c, Complete (c (Interval n, Interval n) x)) => n -> c (Interval n) x -> c (Interval n) x -> c (Interval n) x
ifLowerThan l f g = proc x -> case x of
I.Interval m n
| n <= l -> f -< x
......
......@@ -8,6 +8,7 @@ dependencies:
- base
- hashable
- mtl
- profunctors
- sturdy-lib
- random
- text
......
......@@ -22,6 +22,7 @@ import Data.HashMap.Lazy(HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Text (Text)
import Data.Label
import Data.Profunctor
import Control.Category
import Control.Arrow
......@@ -52,15 +53,21 @@ run ss =
(runEnvT
(runRandomT
(runConcreteT
Generic.run))))
(Generic.run ::
ConcreteT
(RandomT
(EnvT Text Addr
(StoreT Addr Val
(FailureT String
(->))))) [Statement] ())))))
(M.empty,(M.empty,(R.mkStdGen 0, generate <$> ss)))
newtype ConcreteT c x y = ConcreteT { runConcreteT :: c x y }
deriving (Category, Arrow, ArrowChoice, ArrowFail e, ArrowEnv var addr env, ArrowStore addr val)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowFail e, ArrowEnv var addr env, ArrowStore addr val)
deriving instance ArrowFix x y c => ArrowFix x y (ConcreteT c)
deriving instance ArrowRand v c => ArrowRand v (ConcreteT c)
instance (ArrowChoice c) => ArrowAlloc (Text,Val,Label) Addr (ConcreteT c) where
instance (ArrowChoice c, Profunctor c) => ArrowAlloc (Text,Val,Label) Addr (ConcreteT c) where
alloc = arr $ \(_,_,l) -> l
instance (ArrowChoice c, ArrowFail String c) => IsVal Val (ConcreteT c) where
......
......@@ -39,6 +39,7 @@ import qualified Data.Abstract.StackWidening as S
import qualified Data.Abstract.Ordering as O
import qualified Data.Abstract.Equality as E
import Data.Profunctor
import qualified Data.Boolean as B
import Data.Hashable
import Data.Numeric
......@@ -94,11 +95,11 @@ run k env ss =
$ S.reuse (\_ l -> head l)
$ S.fromWidening (M.widening widenVal)
newtype IntervalT c x y = IntervalT { runIntervalT :: c x y } deriving (Category,Arrow,ArrowChoice,ArrowFail e,ArrowEnv var val env,ArrowStore var val,ArrowJoin,PreOrd,Complete)
newtype IntervalT c x y = IntervalT { runIntervalT :: c x y } deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowFail e,ArrowEnv var val env,ArrowStore var val,ArrowJoin,PreOrd,Complete)
type instance Fix x y (IntervalT c) = IntervalT (Fix x y c)
deriving instance ArrowFix x y c => ArrowFix x y (IntervalT c)
instance ArrowChoice c => ArrowAlloc (Text,Val,Label) Addr (IntervalT c) where
instance (ArrowChoice c, Profunctor c) => ArrowAlloc (Text,Val,Label) Addr (IntervalT c) where
alloc = arr $ \(_,_,l) -> return l
instance (ArrowChoice c, ArrowFail String c, ArrowJoin c) => IsVal Val (IntervalT c) where
......@@ -155,7 +156,7 @@ instance (ArrowChoice c,ArrowFail String c, ArrowJoin c) => ArrowCond Val (Inter
NumVal _ -> fail -< "Expected boolean as argument for 'if'"
Top -> (f1 -< x) <> (f2 -< y) <> (fail -< "Expected boolean as argument for 'if'")
instance (ArrowChoice c) => ArrowRand Val (IntervalT c) where
instance (ArrowChoice c, Profunctor c) => ArrowRand Val (IntervalT c) where
random = proc _ -> returnA -< NumVal top
instance PreOrd Val where
......
......@@ -27,6 +27,7 @@ import Data.Abstract.FreeCompletion(FreeCompletion)
import Data.Order
import Data.Label
import Data.Text (Text)
import Data.Profunctor
import Control.Category
import Control.Arrow
......@@ -66,11 +67,11 @@ run env ss =
(M.empty,(M.fromList env,generate <$> ss))
newtype UnitT c x y = UnitT { runUnitT :: c x y }
deriving (Category,Arrow,ArrowChoice,ArrowFail e,ArrowEnv var val env,ArrowStore var val,ArrowJoin,PreOrd,Complete)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowFail e,ArrowEnv var val env,ArrowStore var val,ArrowJoin,PreOrd,Complete)
type instance Fix x y (UnitT c) = UnitT (Fix x y c)
deriving instance ArrowFix x y c => ArrowFix x y (UnitT c)
instance ArrowChoice c => ArrowAlloc (Text,Val,Label) Addr (UnitT c) where
instance (ArrowChoice c,Profunctor c) => ArrowAlloc (Text,Val,Label) Addr (UnitT c) where
alloc = arr $ \(_,_,l) -> return l
instance ArrowChoice c => IsVal Val (UnitT c) where
......@@ -86,7 +87,7 @@ instance ArrowChoice c => IsVal Val (UnitT c) where
eq = arr (const ())
lt = arr (const ())
instance ArrowChoice c => ArrowRand Val (UnitT c) where
instance (ArrowChoice c,Profunctor c) => ArrowRand Val (UnitT c) where
random = arr (const ())
instance (ArrowChoice c, ArrowJoin c) => ArrowCond Val (UnitT c) where
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment