...
 
Commits (5)
name: sturdy-jimple
version: 0.1.0.0
license: BSD3
license-file: LICENSE
author: Wouter Raateland
maintainer: Sven Keidel <svenkeidel@gmail.com>
category: Language
dependencies:
- base
- containers
- unordered-containers
- hashable
- logfloat
- mtl
- random
- sturdy-lib
- text
- vector
- vector-instances
library:
source-dirs:
- src
ghc-options: -Wall
tests:
spec:
main: Spec.hs
source-dirs:
- test
ghc-options: -Wall
dependencies:
- sturdy-pcf
- hspec
{ pkgs ? import <nixpkgs> {} }:
let
haskellPackagesWithProfiling = pkgs.haskellPackages.override {
overrides = self: super: {
mkDerivation = args: super.mkDerivation (args // {
enableLibraryProfiling = false;
});
};
};
hsEnv = haskellPackagesWithProfiling.ghcWithPackages(p: with p; [
Cabal cabal-install hlint text containers hspec mtl numeric-limits criterion fgl
(p.callPackage ../lib/default.nix { })
]);
in pkgs.stdenv.mkDerivation {
name = "sturdy-jimple";
version = "0.0.1";
src = ./.;
buildInputs = [
hsEnv
];
}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module GenericInterpreter where
import Prelude hiding (rem,mod,div,id,or,and,fail,return,map)
import Data.Text (Text)
import Data.Vector (Vector,(!?))
import qualified Data.Vector as Vec
import Data.Int
import Data.IntMap (IntMap)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as Map
import Control.Category
import Control.Arrow
import Control.Arrow.Environment as Env
import Control.Arrow.Frame as Frame
import Control.Arrow.Except as Except
import Control.Arrow.Fail
import Control.Arrow.Fix (ArrowFix(..))
import Control.Arrow.Utils (map)
import GHC.Exts
import Syntax
data Frame val =
Frame
{ this :: val
, params :: Vector val
, locals :: HashMap Text val
, stmts :: Vector Statement
, handlers :: HashMap ClassId CatchClause
, caughtException :: Maybe val
}
type PC = Int
type StmtInterpreter c = c PC ()
type ArrowInterp val e c =
( IsString e, IsVal val c
, ArrowChoice c, ArrowReturn val c
, ArrowFrame (Frame val) c, ArrowEnv Variable val c
, ArrowExcept val c, ArrowFail e c
, ArrowFix (StmtInterpreter c)
, JoinVal () c, JoinVal val c, Env.Join val c, Except.Join () c
)
eval :: ArrowInterp val e c => StmtInterpreter c -> c Expr val
eval run' = proc expr -> case expr of
New typ -> new -< typ
NewArray typ e -> do
len <- evalImmediate -< e
newArray -< (typ,[len])
NewMultiArray typ es -> do
lens <- map evalImmediate -< es
newArray -< (typ,lens)
Cast typ e -> do
val <- evalImmediate -< e
cast -< (typ,val)
InstanceOf e typ -> do
val <- evalImmediate -< e
instanceOf -< (val,typ)
InvokeExpr method ->
evalInvoke run' -< method
Ref ref -> lookup' -< ReferenceVar ref
Binop e1 op e2 -> do
v1 <- evalImmediate -< e1
v2 <- evalImmediate -< e2
case op of
And -> and -< (v1,v2)
Or -> or -< (v1,v2)
Xor -> xor -< (v1,v2)
Rem -> rem -< (v1,v2)
Mod -> mod -< (v1,v2)
Cmp -> cmp -< (v1,v2)
Cmpl -> cmpl -< (v1,v2)
Cmpg -> cmpg -< (v1,v2)
Shl -> shl -< (v1,v2)
Shr -> shr -< (v1,v2)
Ushr -> ushr -< (v1,v2)
Plus -> plus -< (v1,v2)
Minus -> minus -< (v1,v2)
Mult -> mult -< (v1,v2)
Div -> div -< (v1,v2)
Unop op e -> do
v <- evalImmediate -< e
case op of
Lengthof -> lengthOf -< v
Neg -> neg -< v
Immediate e -> evalImmediate -< e
MethodHandle {} -> fail -< "Unsupported operation: MethodHandle"
{-# INLINE eval #-}
evalImmediate :: ArrowInterp val e c => c Immediate val
evalImmediate = proc i -> case i of
Local name -> lookup' -< LocalVar name
DoubleConstant f -> doubleConstant -< f
FloatConstant f -> floatConstant -< f
IntConstant n -> intConstant -< n
LongConstant f -> longConstant -< f
NullConstant -> nullConstant -< ()
StringConstant s -> stringConstant -< s
ClassConstant c -> classConstant -< c
{-# INLINE evalImmediate #-}
evalInvoke :: ArrowInterp val e c => StmtInterpreter c -> c Invoke val
evalInvoke run' = proc e -> case e of
InvokeVirtual obj klass methodSig args -> do
receiver <- lookup' -< obj
invoke -< (receiver,klass,methodSig,args)
InvokeSpecial obj klass methodSig args -> do
receiver <- lookup' -< obj
invoke -< (receiver,klass,methodSig,args)
InvokeInterface obj klass methodSig args -> do
receiver <- lookup' -< obj
invoke -< (receiver,klass,methodSig,args)
InvokeStatic klass methodSig args -> do
receiver <- lookup' -< StaticInstance klass
invoke -< (receiver,klass,methodSig,args)
-- InvokeDynamic {} -> fail -< "We currently do not support dynamic method lookup"
where
invoke = proc (receiver,klass,methodSig,args) -> do
argVals <- map evalImmediate -< args
lookupMethod (proc (receiver,body,argVals) -> do
let frame = Frame { this = receiver
, params = Vec.fromList argVals
, locals = Map.empty
, stmts = statements body
, handlers = catchClauses body
, caughtException = Nothing
}
newFrame (handleReturn run') -< (frame,0)
) -< (receiver,klass,methodSig,argVals)
{-# INLINE invoke #-}
{-# INLINE evalInvoke #-}
run :: ArrowInterp val e c => StmtInterpreter c
run = fix $ \run' -> handleExceptions $ proc pc -> do
let nextStmt = pc + 1
frame <- askFrame -< ()
case stmts frame !? pc of
Nothing -> returnA -< ()
Just stmt -> case stmt of
Goto lab -> run' -< lab
Label {} -> run' -< nextStmt
If e lab -> do
condition <- eval run' -< e
if_ run' run' -< (condition,(lab,nextStmt))
TableSwitch key offset cases def -> do
val <- evalImmediate -< key
tableswitch run' -< (val,offset,cases,def)
LookupSwitch key cases def -> do
val <- evalImmediate -< key
lookupswitch run' -< (val,cases,def)
Identity var ident _maybeTyp -> do
val <- lookup' -< ident
extend run' -< (LocalVar var,val,nextStmt)
Assign var e -> do
val <- eval run' -< e
extend run' -< (var,val,nextStmt)
InvokeStmt invoke -> do
evalInvoke run' -< invoke
run' -< nextStmt
Return Nothing -> returnA -< ()
Return (Just e) -> return <<< evalImmediate -< e
Throw e -> throw <<< evalImmediate -< e
Nop -> run' -< nextStmt
Breakpoint {} -> run' -< nextStmt
-- Unsupported Operations
Ret {} -> fail -< "JVM subroutines are not supported"
EnterMonitor {} -> fail -< "JVM monitor statements are not supported"
ExitMonitor {} -> fail -< "JVM monitor statements are not supported"
{-# INLINE run #-}
handleExceptions :: ArrowInterp val e c => StmtInterpreter c -> StmtInterpreter c
handleExceptions run' = catch run' $ proc (pc,exc) -> do
frame <- askFrame -< ()
matchException (proc (exc,handler) -> Env.extend run' -< (CaughtException,exc,withLabel handler)) -< (exc,pc,handlers frame)
{-# INLINE handleExceptions #-}
class ArrowReturn v c where
return :: c v x
handleReturn :: c x y -> c x v
-- | Interface for value operations.
class IsVal v c | c -> v where
-- | In case of the abstract interpreter allows to join the result
-- of an @if@ statement.
type family JoinVal x (c :: * -> * -> *) :: Constraint
if_ :: JoinVal z c => c x z -> c y z -> c (v, (x, y)) z
tableswitch :: JoinVal y c => c x y -> c (v, Int, Vector Label, Label) y
lookupswitch :: JoinVal y c => c x y -> c (v, IntMap Label, Label) y
lookupMethod :: JoinVal y c => c (v,MethodBody,x) y -> c (v,ClassId,MethodSignature,x) y
matchException :: JoinVal y c => c (v,CatchClause) y -> c (v,PC,HashMap ClassId CatchClause) y
new :: c Type v
newArray :: c (Type,[v]) v
doubleConstant :: c Double v
floatConstant :: c Float v
intConstant :: c Int32 v
longConstant :: c Int64 v
nullConstant :: c () v
stringConstant :: c Text v
classConstant :: c Text v
and :: c (v,v) v
or :: c (v,v) v
xor :: c (v,v) v
rem :: c (v,v) v
mod :: c (v,v) v
cmp :: c (v,v) v
cmpg :: c (v,v) v
cmpl :: c (v,v) v
shl :: c (v,v) v
shr :: c (v,v) v
ushr :: c (v,v) v
plus :: c (v,v) v
minus :: c (v,v) v
mult :: c (v,v) v
lengthOf :: c v v
div :: c (v,v) v
neg :: c v v
cast :: c (Type,v) v
instanceOf :: c (v,Type) v
This diff is collapsed.
This diff is collapsed.
name: sturdy-jimple
version: 0.1.0.0
license: BSD3
license-file: LICENSE
author: Wouter Raateland
maintainer: wouterraateland@gmail.com
category: Language
build-type: Simple
extra-source-files:
cabal-version: >=1.10
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.33.0.
--
-- see: https://github.com/sol/hpack
--
-- hash: 683be31214f2b83403a0b2eddd3a28777bcd124ce83864dfbda0e2595288614d
name: sturdy-jimple
version: 0.1.0.0
category: Language
author: Wouter Raateland
maintainer: Sven Keidel <svenkeidel@gmail.com>
license: BSD3
license-file: LICENSE
build-type: Simple
library
exposed-modules: ConcreteSemantics,
-- IntervalSemantics,
NullnessSemantics,
SharedSemantics,
Syntax,
Data.Concrete.Exception
Data.Abstract.Exception
ghc-options: -Wall
build-depends: base,
containers,
hashable,
mtl,
random,
logfloat,
sturdy-lib,
text,
QuickCheck
hs-source-dirs: src
default-language: Haskell2010
exposed-modules:
ConcreteSemantics
Data.Abstract.Exception
Data.Concrete.Exception
GenericInterpreter
IntervalSemantics
NullnessSemantics
Syntax
other-modules:
Paths_sturdy_jimple
hs-source-dirs:
src
ghc-options: -Wall
build-depends:
base
, containers
, hashable
, logfloat
, mtl
, random
, sturdy-lib
, text
, unordered-containers
, vector
, vector-instances
default-language: Haskell2010
test-suite specs
type: exitcode-stdio-1.0
ghc-options: -Wall
hs-source-dirs: test
main-is: Spec.hs
other-modules: ConcreteSpec,
-- IntervalSpec,
NullnessSpec,
JimpleSoundness,
Soundness,
Utils,
Java.Lang.ArithmeticException,
Java.Lang.ArrayIndexOutOfBoundsException,
Java.Lang.ClassCastException,
Java.Lang.IllegalArgumentException,
Java.Lang.NullPointerException,
Java.Lang.Object,
Java.Lang.Throwable,
Classes.FactorialExample,
Classes.ArrayFieldExample,
Classes.SingleMethodExample,
Classes.PersonExample,
Classes.TryCatchExample
build-depends: base,
containers,
hashable,
logfloat,
hspec,
hspec-core,
sturdy-lib,
sturdy-jimple,
text,
QuickCheck
default-language: Haskell2010
test-suite spec
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
Classes.ArrayFieldExample
Classes.FactorialExample
Classes.PersonExample
Classes.SingleMethodExample
Classes.TryCatchExample
ConcreteSpec
IntervalSpec
Java.Lang.ArithmeticException
Java.Lang.ArrayIndexOutOfBoundsException
Java.Lang.ClassCastException
Java.Lang.IllegalArgumentException
Java.Lang.NullPointerException
Java.Lang.Object
Java.Lang.Throwable
JimpleSoundness
NullnessSpec
Soundness
Utils
Paths_sturdy_jimple
hs-source-dirs:
test
ghc-options: -Wall
build-depends:
base
, containers
, hashable
, hspec
, logfloat
, mtl
, random
, sturdy-lib
, sturdy-pcf
, text
, unordered-containers
, vector
, vector-instances
default-language: Haskell2010
......@@ -11,6 +11,7 @@ dependencies:
- containers
- comonad
- hashable
- hashtables
- mtl
- random
- text
......
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Frame where
import Control.Arrow
import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowFrame frame c | c -> frame where
newFrame :: c x y -> c (frame,x) y
askFrame :: c () frame
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Primitive where
import Control.Arrow
import Control.Arrow.Trans
import Data.Coerce
import Data.Profunctor
import GHC.Exts
import GHC.ST(ST(..))
class (Arrow c, Profunctor c) => ArrowPrimitive c where
type PrimState c :: *
primitive :: ((# State# (PrimState c), x #) -> (# State# (PrimState c), y #)) -> c x y
default primitive :: (c ~ t c', PrimState c ~ PrimState c', ArrowLift t, ArrowPrimitive c')
=> ((# State# (PrimState c), x #) -> (# State# (PrimState c), y #)) -> c x y
primitive f = lift' (primitive f)
{-# INLINE primitive #-}
liftST :: ArrowPrimitive c => (x -> ST (PrimState c) y) -> c x y
liftST f = primitive (\(# s,x #) -> coerce f x s)
{-# INLINE liftST #-}
......@@ -25,10 +25,10 @@ class (Arrow c, Profunctor c) => ArrowStore var val c | c -> var, c -> val where
-- | Writes a value to the store.
write :: c (var,val) ()
-- | Simpler version of 'read'
read' :: (Show var, Join val c, IsString e, ArrowFail e c, ArrowStore var val c) => c var val
read' = proc var ->
read (proc (val,_) -> returnA -< val)
(proc var -> fail -< fromString $ printf "variable %s not bound" (show var))
-< (var,var)
{-# INLINE read' #-}
......@@ -11,7 +11,7 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Control.Arrow.Transformer.Abstract.Fix.Cache where
module Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable where
import Prelude hiding (pred,lookup,map,head,iterate,(.),id,truncate,elem,product,(**))
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Cache.Mutable where
import Prelude hiding ((.))
import Control.Category
import Control.Arrow
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Order hiding (bottom)
import Control.Arrow.Primitive
import Control.Arrow.Trans
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable (Widening)
import Data.Abstract.Stable
import qualified Data.Abstract.Widening as W
import Data.Coerce
import Data.Identifiable
import Data.Monoidal
import Data.Order
import Data.Profunctor
import Data.Profunctor.Unsafe
import Data.HashTable (HashTable)
import qualified Data.HashTable as Map
newtype CacheT cache a b c x y = CacheT { unCacheT :: ConstT (Widening (cache c a b), cache c a b) c x y}
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowPrimitive)
instance ArrowTrans (CacheT cache a b c) where
type Underlying (CacheT cache a b c) x y = (Widening (cache c a b), cache c a b) -> c x y
lift = CacheT . lift
unlift f = unlift (unCacheT f)
{-# INLINE lift #-}
{-# INLINE unlift #-}
instance ArrowLift (CacheT cache a b) where
lift' = CacheT . lift'
{-# INLINE lift' #-}
instance (ArrowRun c) => ArrowRun (CacheT cache a b c) where
type Run (CacheT cache a b c) x y = Widening (cache c a b) -> cache c a b -> Run c x y
run f widen cache = run (unlift f (widen,cache))
{-# INLINE run #-}
instance (Complete y, ArrowEffectCommutative c) => ArrowComplete y (CacheT cache a b c) where
CacheT f <> CacheT g = CacheT $ rmap (uncurry ()) (f &&& g)
{-# INLINE (<⊔>) #-}
instance (Profunctor c, ArrowApply c) => ArrowApply (CacheT cache a b c) where
app = CacheT (app .# first coerce)
{-# INLINE app #-}
instance ArrowEffectCommutative c => ArrowEffectCommutative (CacheT cache a b c)
class NewCache cache a b where
newCache :: ArrowPrimitive c => c () (cache c a b)
----- Basic Cache -----
newtype Cache c a b = Cache (HashTable (PrimState c) a (Stable,b))
type instance Widening (Cache c a b) = W.Widening b
instance NewCache Cache a b where
newCache = rmap Cache Map.new
instance (Identifiable a, LowerBounded b, ArrowChoice c, ArrowPrimitive c)
=> ArrowCache a b (CacheT Cache a b c) where
initialize = lift $ \(_,Cache cache) -> proc a -> do
(_,b) <- Map.initialize -< (a,(Unstable,bottom),cache)
returnA -< b
lookup = lift $ \(_,Cache cache) -> proc a ->
Map.lookup -< (a,cache)
update = lift $ \(widen,Cache cache) -> proc (a,b) -> do
m <- Map.lookup -< (a,cache)
case m of
Just (Stable,b') ->
returnA -< (Stable,b')
Just (Unstable,b') -> do
let b'' = widen b' b
Map.insert -< (a,b'',cache)
returnA -< b''
Nothing -> do
Map.insert -< (a,(Unstable,b),cache)
returnA -< (Unstable,b)
write = lift $ \(_,Cache cache) -> proc (a,b,s) ->
Map.insert -< (a,(s,b),cache)
setStable = lift $ \(_,Cache cache) -> proc (s,a) ->
Map.update (\_ s m -> (fmap (first (const s)) m,())) -< (a,s,cache)
{-# INLINE initialize #-}
{-# INLINE lookup #-}
{-# INLINE write #-}
{-# INLINE update #-}
{-# INLINE setStable #-}
------ Group Cache ------
data Group cache c a b where
Groups :: HashTable (PrimState c) k (cache c a b) -> Group cache c (k,a) b
type instance Widening (Group cache c (k,a) b) = Widening (cache c a b)
instance NewCache (Group cache) (k,a) b where
newCache = rmap Groups Map.new
instance (Identifiable k, NewCache cache a b, ArrowChoice c, ArrowApply c, ArrowCache a b (CacheT cache a b c), ArrowPrimitive c)
=> ArrowCache (k,a) b (CacheT (Group cache) (k,a) b c) where
initialize = withGroup Cache.initialize
lookup = withGroup Cache.lookup
update = lmap assoc2 (withGroup Cache.update)
write = lmap (\((k,a),b,s) -> (k,(a,b,s))) (withGroup Cache.write)
setStable = lmap shuffle1 (withGroup Cache.setStable)
{-# INLINE initialize #-}
{-# INLINE lookup #-}
{-# INLINE write #-}
{-# INLINE update #-}
{-# INLINE setStable #-}
withGroup :: (Identifiable k, NewCache cache a b, ArrowChoice c, ArrowApply c, ArrowPrimitive c)
=> CacheT cache a b c x y -> CacheT (Group cache) (k,a) b c (k,x) y
withGroup f = lift $ \(widen,Groups groups) -> proc (k,a) -> do
m <- Map.lookup -< (k,groups)
cache <- case m of
Just cache -> returnA -< cache
Nothing -> do
cache <- newCache -< ()
Map.insert -< (k,cache,groups)
returnA -< cache
unlift f (widen,cache) -<< a
{-# INLINE withGroup #-}
......@@ -17,6 +17,7 @@ import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Monad
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
import Control.Arrow.Store as Store
......@@ -30,10 +31,9 @@ import Control.Comonad
newtype CokleisliT f c x y = CokleisliT { runCokleisliT :: c (f x) y }
instance (ArrowComonad f c, ArrowRun c) => ArrowRun (CokleisliT f c) where
type Run (CokleisliT f c) x y = Run c (f x) y
instance ArrowTrans (CokleisliT f c) where
type Underlying (CokleisliT f c) x y = c (f x) y
instance (ArrowComonad f c, ArrowRun c) => ArrowRun (CokleisliT f c) where type Run (CokleisliT f c) x y = Run c (f x) y
instance ArrowTrans (CokleisliT f c) where type Underlying (CokleisliT f c) x y = c (f x) y
instance (ArrowComonad f c, ArrowPrimitive c) => ArrowPrimitive (CokleisliT f c) where type PrimState (CokleisliT f c) = PrimState c
instance Comonad f => ArrowLift (CokleisliT f) where
lift' f = lift $ lmap extract f
......
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
......@@ -24,6 +27,7 @@ import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.Context
import Control.Arrow.Fix.Stack
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Store
......@@ -37,7 +41,7 @@ import Data.Coerce
-- | Passes along constant data.
newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y)
deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowLowerBounded,ArrowLift,ArrowJoin,
deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowLowerBounded,ArrowLift,ArrowJoin,ArrowPrimitive,
ArrowState s,ArrowReader r',ArrowWriter w, ArrowLetRec var val,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore var val,
ArrowFail e, ArrowExcept e,
......
......@@ -15,6 +15,7 @@ import Control.Arrow.Cont
import Control.Arrow.Fix
import Control.Arrow.Fail
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.State
......@@ -46,6 +47,9 @@ instance ArrowLift (ContT r) where
lift' f = ContT $ \k -> k . f
{-# INLINE lift' #-}
instance (ArrowApply c, ArrowPrimitive c) => ArrowPrimitive (ContT r c) where
type PrimState (ContT r c) = PrimState c
instance Profunctor c => Profunctor (ContT r c) where
dimap f g h = lift $ \k -> lmap f (unlift h (lmap g k))
lmap f h = lift $ \k -> lmap f (unlift h k)
......
......@@ -20,6 +20,7 @@ import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Monad
import Control.Arrow.Order as Ord
import Control.Arrow.Primitive as Prim
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
import Control.Arrow.Store as Store
......@@ -35,6 +36,7 @@ newtype KleisliT f c x y = KleisliT { runKleisliT :: c x (f y) }
instance (ArrowMonad f c, ArrowRun c) => ArrowRun (KleisliT f c) where type Run (KleisliT f c) x y = Run c x (f y)
instance ArrowTrans (KleisliT f c) where type Underlying (KleisliT f c) x y = c x (f y)
instance (ArrowMonad f c, ArrowPrimitive c) => ArrowPrimitive (KleisliT f c) where type PrimState (KleisliT f c) = PrimState c
instance Monad f => ArrowLift (KleisliT f) where
lift' f = lift $ rmap return f
......
......@@ -21,6 +21,7 @@ import Control.Arrow.Fix.Parallel as Parallel
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Context as Context
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
import Control.Arrow.Store as Store
......@@ -37,6 +38,7 @@ newtype ReaderT r c x y = ReaderT { runReaderT :: c (r,x) y }
instance ArrowRun c => ArrowRun (ReaderT r c) where type Run (ReaderT r c) x y = Run c (r,x) y
instance ArrowTrans (ReaderT r c) where type Underlying (ReaderT r c) x y = c (r,x) y
instance (ArrowPrimitive c) => ArrowPrimitive (ReaderT s c) where type PrimState (ReaderT s c) = PrimState c
instance (Profunctor c) => Profunctor (ReaderT r c) where
dimap f g h = lift $ dimap (second f) g (unlift h)
......
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.ST(runST, ST(..)) where
import Prelude hiding (id,(.),lookup,read,fail)
import Control.Category
import Control.Arrow
import Control.Arrow.Order
import Control.Arrow.Trans
import Control.Arrow.Primitive
import Unsafe.Coerce
import qualified Data.Order as O
import Data.Profunctor hiding (Strong(..))
import Data.Profunctor.Unsafe
import GHC.Exts
-- Arrow version of the ST monad (https://hackage.haskell.org/package/base/docs/Control-Monad-ST.html).
newtype ST s x y = ST ( (# State# s, x #) -> (# State# s, y #) )
instance ArrowPrimitive (ST s) where
type PrimState (ST s) = s
primitive = lift
{-# INLINE primitive #-}
runST :: (forall s. ST s x y) -> (x -> y)
runST (ST f) x = case runRW# (\s -> f (# s, x #)) of { (# _, y #) -> y }
instance ArrowRun (ST s) where
type Run (ST s) x y = ST s x y
run f = f
{-# NOINLINE run #-}
instance ArrowTrans (ST s) where
type Underlying (ST s) x y = (# State# s, x #) -> (# State# s, y #)
instance Profunctor (ST s) where
dimap f g h = arr g . h . arr f
lmap f h = h . arr f
rmap g h = arr g . h
f .# _ = f `seq` unsafeCoerce f
_ #. g = g `seq` unsafeCoerce g
{-# INLINE dimap #-}
{-# INLINE lmap #-}
{-# INLINE rmap #-}
{-# INLINE ( .# ) #-}
{-# INLINE ( #. ) #-}
instance Category (ST c) where
id = lift $ \x -> x
f . g = lift $ \x -> unlift f (unlift g x)
{-# INLINE id #-}
{-# INLINE (.) #-}
instance Arrow (ST s) where
arr f = lift $ \(# s, x #) -> (# s, f x #)
first f = lift $ \(# s, (x,z) #) -> case unlift f (# s, x #) of { (# s', y #) -> (# s', (y,z) #)}
second f = lift $ \(# s, (z,x) #) -> case unlift f (# s, x #) of { (# s', y #) -> (# s', (z,y) #)}
f &&& g = lift $ \(# s, x #) -> case unlift f (# s, x #) of { (# s', y #) -> case unlift g (# s', x #) of { (# s'', z #) -> (# s'', (y,z) #)}}
f *** g = lift $ \(# s, (x,x') #) -> case unlift f (# s, x #) of { (# s', y #) -> case unlift g (# s', x' #) of { (# s'', z #) -> (# s'', (y,z) #)}}
{-# INLINE arr #-}
{-# INLINE first #-}
{-# INLINE second #-}
{-# INLINE (&&&) #-}
{-# INLINE (***) #-}
instance ArrowChoice (ST s) where
left f = lift $ \t -> case t of
(# s, Left x #) -> case unlift f (# s, x #) of
(# s', x' #) -> (# s', Left x' #)
(# s, Right y #) -> (# s, Right y #)
right f = lift $ \t -> case t of
(# s, Left x #) -> (# s, Left x #)
(# s, Right y #) -> case unlift f (# s, y #) of
(# s', y' #) -> (# s', Right y' #)
f ||| g = lift $ \t -> case t of
(# s, Left x #) -> unlift f (# s, x #)
(# s, Right y #) -> unlift g (# s, y #)
f +++ g = lift $ \t -> case t of
(# s, Left x #) -> case unlift f (# s, x #) of
(# s', x' #) -> (# s', Left x' #)
(# s, Right y #) -> case unlift g (# s, y #) of
(# s', y' #) -> (# s', Right y' #)
{-# INLINE left #-}
{-# INLINE right #-}
{-# INLINE (+++) #-}
{-# INLINE (|||) #-}
instance ArrowApply (ST s) where
app = lift $ \(# s, (f,x) #) -> unlift f (# s, x #)
{-# INLINE app #-}
instance ArrowEffectCommutative (ST s)
instance O.Complete y => ArrowComplete y (ST s) where
f <> g = lift $ \(# s, x #) -> case unlift f (# s, x #) of (# s', y #) -> case unlift g (# s', x #) of (# s'' , y' #) -> (# s'', y O. y' #)
{-# INLINE (<⊔>) #-}
......@@ -23,6 +23,7 @@ import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Context as Context
import Control.Arrow.Fix.Widening
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Random
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
......@@ -55,6 +56,7 @@ withStateT f = lift (second (unlift f))
instance ArrowRun c => ArrowRun (StateT s c) where type Run (StateT s c) x y = Run c (s,x) (s,y)
instance ArrowTrans (StateT s c) where type Underlying (StateT s c) x y = c (s,x) (s,y)
instance (ArrowPrimitive c) => ArrowPrimitive (StateT s c) where type PrimState (StateT s c) = PrimState c
instance (Profunctor c) => Profunctor (StateT s c) where
dimap f g h = lift $ dimap (second' f) (second' g) (unlift h)
......
......@@ -19,6 +19,7 @@ import Control.Arrow.Closure as Cls
import Control.Arrow.Except as Exc
import Control.Arrow.Fail
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
import Control.Arrow.Store as Store
......@@ -38,6 +39,10 @@ instance (Applicative f, ArrowRun c) => ArrowRun (StaticT f c) where
{-# INLINE run #-}
{-# SPECIALIZE instance (ArrowRun c) => ArrowRun (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowPrimitive c) => ArrowPrimitive (StaticT f c) where
type PrimState (StaticT f c) = PrimState c
{-# SPECIALIZE instance (ArrowPrimitive c) => ArrowPrimitive (StaticT ((->) r) c) #-}
instance (Applicative f) => ArrowTrans (StaticT f c) where
type Underlying (StaticT f c) x y = f (c x y)
......
......@@ -22,6 +22,7 @@ import Control.Arrow.Except as Exc
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Random
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
......@@ -47,6 +48,9 @@ instance (Monoid w,ArrowRun c) => ArrowRun (WriterT w c) where
instance ArrowTrans (WriterT w c) where
type Underlying (WriterT w c) x y = c x (w,y)
instance (Monoid w,ArrowPrimitive c) => ArrowPrimitive (WriterT w c) where
type PrimState (WriterT w c) = PrimState c
instance (Profunctor c) => Profunctor (WriterT w c) where
dimap f g h = lift $ dimap f (second g) (unlift h)
lmap f h = lift $ lmap f (unlift h)
......
{-# LANGUAGE LambdaCase #-}
{- | Lifts functions from `Data.HashTable.ST.Basic` with `ArrowPrimitive.primitive` -}
module Data.HashTable(HashTable,new,newSized,lookup,insert,update,initialize) where
import Prelude hiding (lookup)
import Control.Arrow.Primitive
import Data.Identifiable
import Data.HashTable.ST.Basic (HashTable)
import qualified Data.HashTable.ST.Basic as Map
new :: ArrowPrimitive c => c () (HashTable (PrimState c) k v)
new = liftST (const Map.new)
{-# INLINE new #-}
newSized :: ArrowPrimitive c => c Int (HashTable (PrimState c) k v)
newSized = liftST Map.newSized
{-# INLINE newSized #-}
lookup :: (Identifiable k, ArrowPrimitive c) => c (k,HashTable (PrimState c) k v) (Maybe v)
lookup = liftST (\(key,table) -> Map.lookup table key)
{-# INLINE lookup #-}
insert :: (Identifiable k, ArrowPrimitive c) => c (k,v,HashTable (PrimState c) k v) ()
insert = liftST (\(key,val,table) -> Map.insert table key val)
{-# INLINE insert #-}
update :: (Identifiable k, ArrowPrimitive c) => (k -> x -> Maybe v -> (Maybe v,y)) -> c (k,x,HashTable (PrimState c) k v) y
update f = liftST $ \(key,x,table) -> Map.mutate table key $ \m -> f key x m
{-# INLINE update #-}
initialize :: (Identifiable k, ArrowPrimitive c) => c (k,v,HashTable (PrimState c) k v) v
initialize = update $ \_ _new -> \case
Just old -> (Just old,old)
Nothing -> (Just _new,_new)
{-# INLINE initialize #-}
......@@ -32,7 +32,7 @@ import Control.Arrow.Transformer.Abstract.Terminating
import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Chaotic
import Control.Arrow.Transformer.Abstract.Fix.Stack
import Control.Arrow.Transformer.Abstract.Fix.Cache hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Context
import qualified Data.Abstract.Boolean as Abs
......
......@@ -11,7 +11,6 @@ import Control.Category
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Fix.Stack (ArrowStack,widenInput,maxSize,reuseByMetric)
import qualified Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Cache (ArrowCache)
import Control.Arrow.Fix.Chaotic (ArrowChaotic,chaotic,iterateInner,iterateOuter)
import Control.Arrow.Fix.Parallel (ArrowParallel,parallel)
......@@ -20,7 +19,7 @@ import Control.Arrow.Transformer.Abstract.Terminating
import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Metrics
import Control.Arrow.Transformer.Abstract.Fix.Chaotic
import Control.Arrow.Transformer.Abstract.Fix.Cache hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Stack
-- import Control.Arrow.Transformer.Abstract.Fix.Trace
......
......@@ -37,7 +37,7 @@ import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Context
import Control.Arrow.Transformer.Abstract.Fix.Stack
-- import Control.Arrow.Transformer.Abstract.Fix.Trace
import Control.Arrow.Transformer.Abstract.Fix.Cache(CacheT,Cache,Parallel,Monotone,type (**),Group)
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable(CacheT,Cache,Parallel,Monotone,type (**),Group)
import Control.Arrow.Transformer.Abstract.Terminating
import Control.Monad.State hiding (lift,fail)
......
......@@ -6,7 +6,7 @@ packages:
- 'pcf'
- 'while'
# - 'stratego'
# - 'jimple'
- 'jimple'
# - 'tutorial'
extra-deps:
- dump-core-0.1.3.2
......
......@@ -41,7 +41,7 @@ import Control.Arrow.Transformer.Abstract.Except
import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Chaotic
import Control.Arrow.Transformer.Abstract.Fix.Context
import Control.Arrow.Transformer.Abstract.Fix.Cache hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Stack
import Control.Arrow.Transformer.Abstract.Store
import Control.Arrow.Transformer.Abstract.Terminating
......
......@@ -48,7 +48,7 @@ import Control.Arrow.Transformer.Abstract.Error
import Control.Arrow.Transformer.Abstract.Except
import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Chaotic
import Control.Arrow.Transformer.Abstract.Fix.Cache
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable
import Control.Arrow.Transformer.Abstract.Fix.Stack
import Control.Arrow.Transformer.Abstract.Store
import Control.Arrow.Transformer.Abstract.Terminating
......