I'm somehow experimenting with GADT. I'm implementing FRP system and I
get such error:
Occurs check: cannot construct the infinite type: a = (a, b)
In the pattern: CircuitSplit f g
In the definition of `createChannel':
createChannel (CircuitSplit f g)
= let
(df, cf) = createChannel f
(dg, cg) = createChannel g
....
in
(df <<< dg,
Map.map merge
$ Map.unionWith
(\ (First x) (Second y) -> Both x y)
(Map.map First cf)
(Map.map Second cf))
On code:
import Control.Applicative
import Control.Arrow
import Control.Category (Category)
import qualified Control.Category
import Control.Monad
import Control.Monad.Fix
import Data.IORef
import Data.Monoid hiding (First)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Unique
import Foreign
import Foreign.C
import Unsafe.Coerce
-- | "CSignal" is a continous signal - i.e. signal which have a value at
each
-- point of time
data CSignal a = CSignal (IO a)
instance Functor CSignal where
f `fmap` (CSignal v) = CSignal $ f <$> v
instance Applicative CSignal where
pure x = CSignal $ pure x
(CSignal f) <*> (CSignal v) = CSignal $ f <*> v
-- | "DSignal" is a discret signal - i.e. signal which is point-like.
data DSignal a = DSignal (Map Unique ((a -> IO ()) -> IO ()))
instance Functor DSignal where
f `fmap` (DSignal l) = DSignal $ Map.map (. (. f)) l
instance Monoid (DSignal a) where
mempty = DSignal Map.empty
(DSignal l) `mappend` (DSignal s) = DSignal $ Map.union l s
-- | Convers the discret signal into a continous signal
readAndCacheSignal :: a -- ^ Inital value
-> DSignal a -- ^ Discret signal
-> IO (CSignal a) -- ^ Continous signal
readAndCacheSignal v (DSignal l) = do
vr <- newIORef v
Map.fold (>>) (return ()) $ Map.map ($ writeIORef vr) l
return $ CSignal $ readIORef vr
data Circuit a b where
CircuitCSignal :: CSignal a -> Circuit () a
CircuitDSignal :: DSignal a -> Circuit () (Maybe a)
CircuitArr :: Kleisli IO a b -> Circuit a b
CircuitJoint :: Circuit b c -> Circuit a b -> Circuit a c
CircuitSplit :: Circuit a c -> Circuit b d -> Circuit (a, b) (c, d)
CircuitChoice :: Circuit a c -> Circuit b d
-> Circuit (Either a b) (Either c d)
CircuitLoop :: Circuit (a, c) (b, c) -> Circuit a b
instance Category Circuit where
id = CircuitArr returnA
f . g = CircuitJoint f g
instance Arrow Circuit where
arr f = CircuitArr $ arr f
first = flip CircuitSplit returnA
second = CircuitSplit returnA
(***) = CircuitSplit
instance ArrowChoice Circuit where
left = flip CircuitChoice returnA
right = CircuitChoice returnA
(+++) = CircuitChoice
instance ArrowLoop Circuit where
loop = CircuitLoop
data CircuitChannel a b where
CircuitChannel :: Kleisli IO (c, a) b
-> ((c -> IO ()) -> IO ())
-> CircuitChannel a b
data ChannelJoin a b = First a
| Second b
| Both a b
createChannel :: Circuit a b
-> (Kleisli IO a b, Map Unique (CircuitChannel a b))
createChannel (CircuitCSignal (CSignal v)) = (Kleisli (const v),
Map.empty)
createChannel (CircuitDSignal (DSignal l)) =
(arr $ const Nothing, Map.map (CircuitChannel (arr $ Just . snd)) l)
createChannel (CircuitArr a) = (a, Map.empty)
createChannel (CircuitJoint f g) =
let (df, cf) = createChannel f
(dg, cg) = createChannel g
merge (First (CircuitChannel a r)) =
CircuitChannel (dg <<< a) r
merge (Second (CircuitChannel a r)) =
CircuitChannel (a <<< second df) r
merge (Both (CircuitChannel a r) (CircuitChannel b _)) =
CircuitChannel (proc (d, v) -> do v' <- b -< (d, v)
a -< (d, v')) r
in (df <<< dg,
Map.map merge $
Map.unionWith (\(First x) (Second y) -> Both x y)
(Map.map First cf) (Map.map Second cf))
createChannel (CircuitSplit f g) =
let (df, cf) = createChannel f
(dg, cg) = createChannel g
merge (First (CircuitChannel a r)) =
CircuitChannel (proc (e, (c, d)) -> do c' <- a -< (e, c)
d' <- dg -< d
returnA -< (c', d'))
r
merge (Second (CircuitChannel b r)) =
CircuitChannel (proc (e, (c, d)) -> do c' <- df -< c
d' <- b -< (e, d)
returnA -< (c', d'))
r
merge (Both (CircuitChannel a r) (CircuitChannel b _)) =
CircuitChannel (proc (e, (c, d)) -> do c' <- a -< (e, c)
d' <- b -< (e, d)
returnA -< (c', d'))
r
in (df <<< dg,
Map.map merge $
Map.unionWith (\(First x) (Second y) -> Both x y)
(Map.map First cf) (Map.map Second cf))
createChannel (CircuitChoice f g) =
let (df, cf) = createChannel f
(dg, cg) = createChannel g
merge (First (CircuitChannel a r)) =
CircuitChannel (proc (e, c) ->
case c of
Left x -> a -< (e, x)
Right x -> dg -< x) r
merge (Second (CircuitChannel a r)) =
CircuitChannel (proc (e, c) ->
case c of
Left x -> df -< x
Right x -> a -< (e, x)) r
merge (Both (CircuitChannel a r) (CircuitChannel b _)) =
CircuitChannel (proc (e, c) ->
case c of
Left x -> a -< (e, x)
Right x -> b -< (e, x)) r
in (df ||| dg,
Map.map merge $
Map.unionWith (\(First x) (Second y) -> Both x y)
(Map.map First cf) (Map.map Second cf))
createChannel (CircuitLoop f) =
let (df, cf) = createChannel f
in (loop df,
Map.map (\(CircuitChannel a r) ->
CircuitChannel (proc (e, a) -> do
rec (b, c) <- a -< (e, (a, c))
returnA -< b) r) cf)
I know that it will require some sort of type voodoo but where's error
now?
Regards
