Verified Commit b99feafa authored by Sven Keidel's avatar Sven Keidel
Browse files

add a finite environment abstraction

parent 81c717f7
Pipeline #26652 failed with stages
in 22 minutes and 18 seconds
......@@ -24,8 +24,9 @@ class (Arrow c, Profunctor c) => ArrowClosure expr cls c | cls -> expr where
closure = lift' closure
{-# INLINE closure #-}
class IsClosure cls env | env -> cls, cls -> env where
class IsClosure cls env where
mapEnvironment :: (env -> env) -> cls -> cls
traverseEnvironment :: Applicative f => (env -> f env) -> cls -> f cls
setEnvironment :: env -> cls -> cls
setEnvironment env = mapEnvironment (const env)
{-# INLINE setEnvironment #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix(Fix,Fix',ArrowFix(..),IterationStrategy,transform,filter) where
module Control.Arrow.Fix(Fix,Fix',ArrowFix(..)) where
import Prelude hiding (filter,pred)
import Control.Arrow
import Control.Arrow.Trans
import Data.Profunctor
import Data.Lens(Iso',from,Prism',getMaybe,get,set)
-- | Type family that computes the type of the fixpoint.
type family Fix (c :: * -> * -> *) x y :: * -> * -> *
type Fix' c x y = Fix c x y x y
......@@ -34,16 +28,3 @@ class ArrowFix c where
type instance Fix (->) x y = (->)
instance ArrowFix (x -> y) where
fix f = f (fix f)
type IterationStrategy c a b = c a b -> c a b
transform :: Profunctor c => Iso' a a' -> IterationStrategy c a' b -> IterationStrategy c a b
transform iso strat f = lmap (get iso) (strat (lmap (get (from iso)) f))
{-# INLINE transform #-}
filter :: (Profunctor c, ArrowChoice c, ArrowApply c) => Prism' a a' -> IterationStrategy c a' b -> IterationStrategy c a b
filter pred strat f = proc a -> case getMaybe pred a of
Just a' -> strat (lmap (\x -> set pred x a) f) -<< a'
Nothing -> f -< a
{-# INLINE filter #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Fix.Cache where
import Prelude hiding (lookup)
import Control.Arrow
import Control.Arrow.Trans
import Data.Profunctor
import Data.Abstract.Stable
class (Arrow c, Profunctor c) => ArrowCache a b c | c -> a, c -> b where
type Widening c :: *
-- | Initializes a cache entry with 'bottom'.
initialize :: c a b
-- | Looks up if there is an entry in the cache.
lookup :: c a (Maybe (Stable,b))
......@@ -17,3 +26,21 @@ class (Arrow c, Profunctor c) => ArrowCache a b c | c -> a, c -> b where
-- | Set a given entry to stable or unstable.
setStable :: c (Stable,a) ()
default initialize :: (c ~ t c', ArrowLift t, ArrowCache a b c') => c a b
default lookup :: (c ~ t c', ArrowLift t, ArrowCache a b c') => c a (Maybe (Stable,b))
default write :: (c ~ t c', ArrowLift t, ArrowCache a b c') => c (a,b,Stable) ()
default update :: (c ~ t c', ArrowLift t, ArrowCache a b c') => c (a,b) (Stable,b)
default setStable :: (c ~ t c', ArrowLift t, ArrowCache a b c') => c (Stable,a) ()
initialize = lift' initialize
lookup = lift' lookup
write = lift' write
update = lift' update
setStable = lift' setStable
{-# INLINE initialize #-}
{-# INLINE lookup #-}
{-# INLINE write #-}
{-# INLINE update #-}
{-# INLINE setStable #-}
......@@ -14,13 +14,10 @@ import Data.Order
import Text.Printf
class (Arrow c, Profunctor c) => ArrowIterate a c where
-- | Remembers to iterate on an unstable result until it stabilized.
class (Arrow c, Profunctor c) => ArrowChaotic a c | c -> a where
iterate :: c (a,b) b
class (Arrow c, Profunctor c) => ArrowComponent a c | c -> a where
setComponent :: c (Component a,y) y
withComponent :: c x y -> (c (x,y,Component a) y) -> c x y
withComponent :: c x y -> c (x,y,Component a) y -> c x y
data Component a = Component { head :: HashSet a, body :: HashSet a } deriving (Eq)
......
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Fix.Combinator
( FixpointCombinator
, iterateInner
, iterateOuter
, transform
, filter
, reuseFirst
, reuseExact
, reuseByMetric
, reuseStableByMetric
, maxSize
, widenInput
, callsiteSensitive
, callsiteSensitive'
, recordCallsite
, trace
, trace'
, traceCache
, traceCtx
, traceShow
)
where
import Prelude hiding ((.),pred,lookup,filter,head,iterate,map)
import Control.Category
import Control.Arrow hiding (loop)
import Control.Arrow.State(ArrowState)
import qualified Control.Arrow.State as State
import Control.Arrow.Fix.Stack (ArrowStack)
import qualified Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Context (ArrowContext,ArrowJoinContext)
import qualified Control.Arrow.Fix.Context as Ctx
import Control.Arrow.Fix.Reuse as Reuse
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Chaotic
import Control.Arrow.Utils (map)
import Data.Abstract.Widening as W
import Data.Abstract.Stable
import Data.Abstract.CallString as CallString
import Data.Order
import Data.Metric
import Data.Monoid (First(..))
import Data.Profunctor
import Data.Lens (Iso',from,Prism',getMaybe,get,set)
import Data.Identifiable
import qualified Data.HashSet as H
import Text.Printf
import qualified Debug.Trace as Debug
type FixpointCombinator c x y = c x y -> c x y
-- | Iterate on the innermost fixpoint component.
iterateInner :: forall a b c. (Identifiable a, ArrowStack a c, ArrowChaotic a c, ArrowCache a b c, ArrowChoice c) => FixpointCombinator c a b
{-# INLINE iterateInner #-}
iterateInner = detectLoop . go
where
go f = withComponent f $ proc (a,b,component) ->
-- The call did not depend on any unstable calls. This means
-- we are done and don't need to iterate.
if H.null (head component)
then do
Cache.write -< (a,b,Stable)
returnA -< b
else do
(stable,bNew) <- Cache.update -< (a,b)
case stable of
Stable ->
if head component == H.singleton a
then do
map Cache.setStable -< (Stable,) <$> H.toList (body component)
setComponent -< (mempty, bNew)
else do
setStable -< (Unstable,a)
setComponent -< (component { head = H.delete a (head component)
, body = H.insert a (body component) }, bNew)
Unstable -> go f -< a
-- | Iterate on the outermost fixpoint component.
iterateOuter :: forall a b c. (Identifiable a, ArrowStack a c, ArrowChaotic a c, ArrowCache a b c, ArrowChoice c) => FixpointCombinator c a b
{-# INLINE iterateOuter #-}
iterateOuter = detectLoop . go
where
go f = withComponent f $ proc (a,b,component) -> case () of
-- The call did not depend on any unstable calls. This means
-- we are done and don't need to iterate.
() | H.null (head component) -> do
Cache.write -< (a,b,Stable)
setComponent -< (mempty,b)
-- We are at the head of a fixpoint component. This means, we
-- have to iterate until the head stabilized.
| head component == H.singleton a -> do
(stable,bNew) <- Cache.update -< (a,b)
case stable of
-- If the head of a fixpoint component is stable, set
-- all elements in the body of the component as stable
-- too and return.
Stable -> do
map Cache.setStable -< H.toList $ H.map (Stable,) (body component)
setComponent -< (mempty, bNew)
-- If the head of a fixpoint component is not stable, keep iterating.
Unstable ->
go f -< a
-- We are inside an fixpoint component, but its head has not stabilized.
| otherwise -> do
Cache.write -< (a,b,Unstable)
setComponent -< (Component { head = H.delete a (head component),
body = H.insert a (body component) }, b)
detectLoop :: (ArrowStack a c, ArrowCache a b c, ArrowChaotic a c, ArrowChoice c) => FixpointCombinator c a b
detectLoop f = proc a -> do
loop <- Stack.elem -< a
if loop
then do
m <- Cache.lookup -< a
case m of
Just (Stable,b) -> returnA -< b
Just (Unstable,b) -> iterate -< (a, b)
Nothing -> do
b <- initialize -< a
iterate -< (a, b)
else Stack.push f -< a
{-# INLINE detectLoop #-}
transform :: Profunctor c => Iso' a a' -> FixpointCombinator c a' b -> FixpointCombinator c a b
transform iso strat f = lmap (get iso)
$ strat
$ lmap (get (from iso)) f
{-# INLINE transform #-}
filter :: forall a a' b c. (Profunctor c, ArrowChoice c, ArrowApply c) => Prism' a a' -> FixpointCombinator c a' b -> FixpointCombinator c a b
filter pred strat f = proc a -> case getMaybe pred a of
Just a' -> strat (lmap (\x -> set pred x a) f) -<< a'
Nothing -> f -< a
{-# INLINE filter #-}
reuseFirst :: (PreOrd a, ArrowChoice c, ArrowReuse a b c) => Stable -> FixpointCombinator c a b
reuseFirst s f = proc a -> do
m <- reuse s (\a a' s' b' m -> case m of
First (Just _) -> m
First Nothing
| a a' -> First (Just (a',b',s'))
| otherwise -> m) -< a
case getFirst m of
Just (_,b,Stable) -> returnA -< b
Just (a',_,Unstable) -> f -< a'
Nothing -> f -< a
{-# INLINE reuseFirst #-}
reuseExact :: (ArrowChoice c, ArrowCache a b c) => FixpointCombinator c a b
reuseExact f = proc a -> do
m <- lookup -< a
case m of
Just (Stable,b) -> returnA -< b
_ -> f -< a
{-# INLINE reuseExact #-}
reuseByMetric :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> FixpointCombinator c a b
reuseByMetric metric = reuseByMetric_ (\s a a' -> Product s (metric a a')) Unstable
{-# INLINE reuseByMetric #-}
reuseStableByMetric :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> FixpointCombinator c a b
reuseStableByMetric metric = reuseByMetric_ (const metric) Stable
{-# INLINE reuseStableByMetric #-}
reuseByMetric_ :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => (Stable -> Metric a n) -> Stable -> FixpointCombinator c a b
reuseByMetric_ metric s f = proc a -> do
m <- reuse s (\a a' s' b' m ->
if a a'
then m <> Just (Measured { input = a', output = b', isStable = s', measured = metric s' a a' })
else m) -< a
case m of
Just Measured { isStable = Stable, output = b } -> returnA -< b
Just Measured { isStable = Unstable, input = a' } -> f -< a'
Nothing -> f -< a
{-# INLINE reuseByMetric_ #-}
data Measured a b n = Measured { input :: a, output :: b, isStable :: Stable, measured :: n }
instance (Show a, Show b, Show n) => Show (Measured a b n) where
show m = printf "%s@%s" (show (output m)) (show (measured m))
instance Ord n => Semigroup (Measured a b n) where
m1 <> m2
| measured m1 <= measured m2 = m1
| otherwise = m2
{-# INLINE (<>) #-}
maxSize :: (ArrowChoice c, ArrowStack a c) => Int -> FixpointCombinator c a b -> FixpointCombinator c a b
maxSize limit strat f = proc a -> do
n <- Stack.size -< ()
if n < limit
then f -< a
else strat f -< a
{-# INLINE maxSize #-}
widenInput :: (Complete a, ArrowStack a c) => W.Widening a -> FixpointCombinator c a b
widenInput widen f = proc a -> do
m <- Stack.peek -< ()
f -< case m of
Nothing -> a
Just x -> snd $ x `widen` (x a)
{-# INLINE widenInput #-}
callsiteSensitive :: forall a lab b c. (ArrowContext (CallString lab) c, ArrowJoinContext a c) => Int -> (a -> lab) -> FixpointCombinator c a b
callsiteSensitive k getLabel = callsiteSensitive' k (Just . getLabel)
{-# INLINE callsiteSensitive #-}
callsiteSensitive' :: forall a lab b c. (ArrowContext (CallString lab) c, ArrowJoinContext a c) => Int -> (a -> Maybe lab) -> FixpointCombinator c a b
callsiteSensitive' k getLabel f = recordCallsite k getLabel $ f . Ctx.joinByContext
{-# INLINE callsiteSensitive' #-}
recordCallsite :: forall a lab b c. ArrowContext (CallString lab) c => Int -> (a -> Maybe lab) -> FixpointCombinator c a b
recordCallsite k getLabel g = proc a -> do
callString <- Ctx.askContext -< ()
let callString' = case getLabel a of
Just lab -> CallString.truncate k (CallString.push lab callString)
Nothing -> callString
Ctx.localContext g -< (callString',a)
{-# INLINE recordCallsite #-}
trace :: (Arrow c) => (a -> String) -> (b -> String) -> FixpointCombinator c a b
trace showA showB f = proc x -> do
y <- f -< Debug.trace (printf "CALL\n%s\n\n" (showA x)) x
returnA -< Debug.trace (printf "RETURN\n%s\n%s\n\n" (showA x) (showB y)) y
{-# INLINE trace #-}
trace' :: (Eq a, ArrowApply c) => (a -> String) -> (b -> String) -> FixpointCombinator c a b -> FixpointCombinator c a b
trace' showA showB strat f = proc x -> do
y <- strat (proc x' -> f -< Debug.trace (if x == x'
then printf "CALL\n%s\n\n" (showA x)
else printf "CALL\n%s~>\n%s\n\n" (showA x) (showA x')) x') -<< x
returnA -< Debug.trace (printf "RETURN\n%s\n%s\n\n" (showA x) (showB y)) y
{-# INLINE trace' #-}
traceCache :: ArrowState cache c => (cache -> String) -> FixpointCombinator c a b
traceCache showCache f = proc a -> do
cache <- State.get -< ()
f -< Debug.trace (printf "CACHE %s\n\n" (showCache cache)) a
{-# INLINE traceCache #-}
traceCtx :: (ArrowContext ctx a' c,ArrowState cache c) => (a -> String) -> (b -> String) -> (ctx -> String) -> (cache -> String) -> FixpointCombinator c a b
traceCtx showA showB showCtx showCache f = proc x -> do
ctx <- Ctx.askContext -< ()
cache <- State.get -< ()
y <- f -< Debug.trace (printf "CALL\n%s\n%s\n%s\n\n" (showA x) (showCtx ctx) (showCache cache)) x
returnA -< Debug.trace (printf "RETURN\n%s\n%s\n%s\n\n" (showA x) (showCtx ctx) (showB y)) y
{-# INLINE traceCtx #-}
traceShow :: (Show a, Show b, Arrow c) => FixpointCombinator c a b
traceShow = trace show show
{-# INLINE traceShow #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix.Context where
import Prelude hiding ((.))
import Control.Category
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Trans
import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowContext ctx a c | c -> ctx, c -> a where
type Widening c a :: *
class (Arrow c, Profunctor c) => ArrowContext ctx c | c -> ctx where
askContext :: c () ctx
localContext :: c x y -> c (ctx,x) y
joinByContext :: Widening c a -> c a a
joinByContext' :: ArrowContext ctx a c => Widening c a -> IterationStrategy c a b
joinByContext' widen f = f . joinByContext widen
{-# INLINE joinByContext' #-}
default askContext :: (c ~ t c', ArrowLift t, ArrowContext ctx c') => c () ctx
askContext = lift' askContext
{-# INLINE askContext #-}
class (Arrow c, Profunctor c) => ArrowJoinContext a c | c -> a where
joinByContext :: c a a
default joinByContext :: (c ~ t c', ArrowLift t, ArrowJoinContext a c') => c a a
joinByContext = lift' joinByContext
{-# INLINE joinByContext #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix.Reuse
( ArrowReuse(..)
, reuseFirst
, reuseExact
, reuseByMetric
, reuseStableByMetric
)
module Control.Arrow.Fix.Reuse ( ArrowReuse(..))
where
import Prelude hiding (lookup)
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Fix.Cache
import Data.Abstract.Stable
import Data.Order
import Data.Metric
import Data.Profunctor
import Data.Monoid (First(..))
import Text.Printf
class (Arrow c, Profunctor c) => ArrowReuse a b c where
-- | Reuse cached results at the cost of precision.
reuse :: (Monoid m) => Stable -> (a -> a -> Stable -> b -> m -> m) -> c a m
reuseFirst :: (PreOrd a, ArrowChoice c, ArrowReuse a b c) => Stable -> IterationStrategy c a b
reuseFirst s f = proc a -> do
m <- reuse s (\a a' s' b' m -> case m of
First (Just _) -> m
First Nothing
| a a' -> First (Just (a',b',s'))
| otherwise -> m) -< a
case getFirst m of
Just (_,b,Stable) -> returnA -< b
Just (a',_,Unstable) -> f -< a'
Nothing -> f -< a
{-# INLINE reuseFirst #-}
reuseExact :: (ArrowChoice c, ArrowCache a b c) => IterationStrategy c a b
reuseExact f = proc a -> do
m <- lookup -< a
case m of
Just (Stable,b) -> returnA -< b
_ -> f -< a
{-# INLINE reuseExact #-}
reuseByMetric :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b
reuseByMetric metric = reuseByMetric_ (\s a a' -> Product s (metric a a')) Unstable
{-# INLINE reuseByMetric #-}
reuseStableByMetric :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b
reuseStableByMetric metric = reuseByMetric_ (const metric) Stable
{-# INLINE reuseStableByMetric #-}
reuseByMetric_ :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => (Stable -> Metric a n) -> Stable -> IterationStrategy c a b
reuseByMetric_ metric s f = proc a -> do
m <- reuse s (\a a' s' b' m ->
if a a'
then m <> Just (Measured { input = a', output = b', stable = s', measured = metric s' a a' })
else m) -< a
case m of
Just Measured { stable = Stable, output = b } -> returnA -< b
Just Measured { stable = Unstable, input = a' } -> f -< a'
Nothing -> f -< a
{-# INLINE reuseByMetric_ #-}
data Measured a b n = Measured { input :: a, output :: b, stable :: Stable, measured :: n }
instance (Show a, Show b, Show n) => Show (Measured a b n) where
show m = printf "%s@%s" (show (output m)) (show (measured m))
instance Ord n => Semigroup (Measured a b n) where
m1 <> m2
| measured m1 <= measured m2 = m1
| otherwise = m2
{-# INLINE (<>) #-}
......@@ -36,7 +36,7 @@ import Data.Coerce
newtype ErrorT e c x y = ErrorT (KleisliT (Error e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowCont, ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore a b,
ArrowEnv var val, ArrowLetRec var val, ArrowClosure expr cls, ArrowStore a b,
ArrowExcept e')
runErrorT :: ErrorT e c x y -> c x (Error e y)
......
......@@ -16,7 +16,6 @@ import qualified Prelude as P
import Control.Category
import Control.Arrow
import Control.Arrow.Fix.Context
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Transformer.Const
......@@ -28,6 +27,7 @@ import Control.Arrow.Store
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Trans
import Control.Arrow.Fix.Context
import Control.Arrow.Environment as Env
import Control.Arrow.Closure
import Control.Arrow.Fix
......@@ -50,10 +50,11 @@ import Data.Coerce
type Alloc var addr val c = EnvT var addr val c (var,val) addr
newtype EnvT var addr val c x y = EnvT (ConstT (Alloc var addr val c) (ReaderT (HashMap var addr) (StateT (HashMap addr val) c)) x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans, ArrowLowerBounded,
ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowRun, ArrowCont)
ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowRun, ArrowCont,
ArrowContext ctx a)
instance (Identifiable var, Identifiable addr, Complete val, ArrowEffectCommutative c, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvT var addr val c) where
type Join y (EnvT var addr val c) = Env.Join y c
type Join y (EnvT var addr val c) = ()
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
env <- Reader.ask -< ()
store <- State.get -< ()
......@@ -74,18 +75,19 @@ instance (Identifiable var, Identifiable addr, Complete val, ArrowEffectCommutat
{-# INLINE lookup #-}
{-# INLINE extend #-}
instance (Identifiable var, Identifiable addr, Identifiable expr, ArrowEffectCommutative c, ArrowChoice c, Profunctor c) => ArrowClosure expr (Closure expr (HashSet (HashMap var addr))) (EnvT var addr val c) where
instance (Identifiable var, Identifiable addr, Identifiable expr, ArrowEffectCommutative c, ArrowChoice c, Profunctor c) =>
ArrowClosure expr (Closure expr (HashSet (HashMap var addr))) (EnvT var addr val c) where
type Join y (EnvT var addr val c) = Complete y
closure = EnvT $ proc expr -> do
env <- Reader.ask -< ()
returnA -< Cls.closure expr (Set.singleton env)
apply (EnvT f) = Cls.apply $proc ((expr,envs),x) ->
apply (EnvT f) = Cls.apply $ proc ((expr,envs),x) ->
(| joinList (error "encountered an empty set of environments" -< ())
(\env -> EnvT (Reader.local f) -< (env,(expr,x))) |) (Set.toList envs)
{-# INLINE closure #-}
{-# INLINE apply #-}
instance (Identifiable var, Identifiable addr, Complete val, IsClosure val (HashSet (HashMap var addr)), ArrowEffectCommutative c, ArrowContext addr a c, ArrowChoice c, Profunctor c) => ArrowLetRec var val (EnvT var addr val c) where
instance (Identifiable var, Identifiable addr, Complete val, IsClosure val (HashSet (HashMap var addr)), ArrowEffectCommutative c, ArrowChoice c, Profunctor c) => ArrowLetRec var val (EnvT var addr val c) where
letRec (EnvT f) = EnvT $ askConst $ \(EnvT alloc) -> proc (bindings,x) -> do
env <- Reader.ask -< ()
addrs <- map alloc -< bindings
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Ge