[Haskell-cafe] [Long] 'Fun' with types

[Maciej Piechotka]

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
-------------- next part --------------
A non-text attachment was scrubbed...
Name: not available
Type: application/pgp-signature
Size: 198 bytes
Desc: This is a digitally signed message part
Url : http://www.haskell.org/pipermail/haskell-cafe/attachments/20090903/8e99940a/attachment.bin