ENH welcome to rankN hell
This commit is contained in:
parent
fa37cd5d46
commit
0a0a734817
|
@ -1,5 +1,7 @@
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -220,7 +222,8 @@ data Root a = forall p. IORoot (p -> a) (Tree IODependency IODependency_ p)
|
||||||
|
|
||||||
-- | The dependency tree with rules to merge results
|
-- | The dependency tree with rules to merge results
|
||||||
data Tree d d_ p =
|
data Tree d d_ p =
|
||||||
And12 (p -> p -> p) (Tree d d_ p) (Tree d d_ p)
|
forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
|
||||||
|
-- And12 (p -> p -> p) (Tree d d_ p) (Tree d d_ p)
|
||||||
| And1 (Tree d d_ p) (Tree_ d_)
|
| And1 (Tree d d_ p) (Tree_ d_)
|
||||||
| And2 (Tree_ d_) (Tree d d_ p)
|
| And2 (Tree_ d_) (Tree d d_ p)
|
||||||
| Or (Tree d d_ p) (Tree d d_ p)
|
| Or (Tree d d_ p) (Tree d d_ p)
|
||||||
|
@ -343,7 +346,9 @@ testRoot r = do
|
||||||
(DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDependency_ cl) t
|
(DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDependency_ cl) t
|
||||||
_ -> return $ Left $ PostMissing "client not available"
|
_ -> return $ Left $ PostMissing "client not available"
|
||||||
where
|
where
|
||||||
go a f_ f t = bimap PostFail (fmap a) <$> testTree f_ f t
|
-- rank N polymorphism is apparently undecidable...gross
|
||||||
|
go a f_ (f :: forall q. d q -> IO (Result q)) t =
|
||||||
|
bimap PostFail (fmap a) <$> testTree f_ f t
|
||||||
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
|
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -351,10 +356,11 @@ testRoot r = do
|
||||||
|
|
||||||
type Result p = Either [String] (PostPass p)
|
type Result p = Either [String] (PostPass p)
|
||||||
|
|
||||||
testTree :: (d_ -> IO Result_) -> (d p -> IO (Result p)) -> Tree d d_ p
|
testTree :: forall d d_ p. (d_ -> IO Result_) -> (forall q. d q -> IO (Result q))
|
||||||
-> IO (Either [String] (PostPass p))
|
-> Tree d d_ p -> IO (Either [String] (PostPass p))
|
||||||
testTree test_ test = go
|
testTree test_ test = go
|
||||||
where
|
where
|
||||||
|
go :: forall q. Tree d d_ q -> IO (Either [String] (PostPass q))
|
||||||
go (And12 f a b) = do
|
go (And12 f a b) = do
|
||||||
ra <- go a
|
ra <- go a
|
||||||
liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
|
liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
|
||||||
|
@ -616,11 +622,12 @@ dumpRoot (DBusRoot _ t Nothing) =
|
||||||
dumpRoot (DBusRoot_ _ t Nothing) =
|
dumpRoot (DBusRoot_ _ t Nothing) =
|
||||||
return (jsonDBusRoot $ dataTree_ dataDBusDependency t, False)
|
return (jsonDBusRoot $ dataTree_ dataDBusDependency t, False)
|
||||||
|
|
||||||
dumpTree :: (d p -> IO (Result p)) -> (d_ -> IO Result_)
|
dumpTree :: forall d d_ p. (forall q. d q -> IO (Result q))
|
||||||
-> (d p -> DependencyData) -> (d_ -> DependencyData) -> Tree d d_ p
|
-> (d_ -> IO Result_) -> (forall q. d q -> DependencyData)
|
||||||
-> IO (JSONUnquotable, Bool)
|
-> (d_ -> DependencyData) -> Tree d d_ p -> IO (JSONUnquotable, Bool)
|
||||||
dumpTree test test_ dd dd_ = go
|
dumpTree test test_ dd dd_ = go
|
||||||
where
|
where
|
||||||
|
go :: forall q. Tree d d_ q -> IO (JSONUnquotable, Bool)
|
||||||
go (And12 _ a b) = doAnd go go data' a b
|
go (And12 _ a b) = doAnd go go data' a b
|
||||||
go (And1 a b) = doAnd go dump_' (dataTree_ dd_) a b
|
go (And1 a b) = doAnd go dump_' (dataTree_ dd_) a b
|
||||||
go (And2 a b) = doAnd dump_' go data' a b
|
go (And2 a b) = doAnd dump_' go data' a b
|
||||||
|
@ -632,8 +639,9 @@ dumpTree test test_ dd dd_ = go
|
||||||
r <- fromResult <$> test d
|
r <- fromResult <$> test d
|
||||||
let (x, y) = dd d
|
let (x, y) = dd d
|
||||||
return (jsonLeaf (Just r) x y, fst r)
|
return (jsonLeaf (Just r) x y, fst r)
|
||||||
dump_' = dumpTree_ test_ dd_
|
data' :: forall q. Tree d d_ q -> JSONUnquotable
|
||||||
data' = dataTree dd dd_
|
data' = dataTree dd dd_
|
||||||
|
dump_' = dumpTree_ test_ dd_
|
||||||
doAnd fa fb fb_ a b = do
|
doAnd fa fb fb_ a b = do
|
||||||
(sa, ra) <- fa a
|
(sa, ra) <- fa a
|
||||||
let j = jsonAnd sa
|
let j = jsonAnd sa
|
||||||
|
@ -671,9 +679,11 @@ dataRoot (IORoot_ _ t) = dataTree_ dataIODependency_ t
|
||||||
dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t
|
dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t
|
||||||
dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t
|
dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t
|
||||||
|
|
||||||
dataTree :: (d p -> DependencyData) -> (d_ -> DependencyData) -> Tree d d_ p -> JSONUnquotable
|
dataTree :: forall d d_ p. (forall q. d q -> DependencyData)
|
||||||
|
-> (d_ -> DependencyData) -> Tree d d_ p -> JSONUnquotable
|
||||||
dataTree f f_ = go
|
dataTree f f_ = go
|
||||||
where
|
where
|
||||||
|
go :: forall q. Tree d d_ q -> JSONUnquotable
|
||||||
go (And12 _ a b) = jsonAnd (go a) (go b)
|
go (And12 _ a b) = jsonAnd (go a) (go b)
|
||||||
go (And1 a b) = jsonAnd (go a) (dataTree_ f_ b)
|
go (And1 a b) = jsonAnd (go a) (dataTree_ f_ b)
|
||||||
go (And2 a b) = jsonAnd (dataTree_ f_ a) (go b)
|
go (And2 a b) = jsonAnd (dataTree_ f_ a) (go b)
|
||||||
|
|
Loading…
Reference in New Issue