ArrTest.hs

{-# LANGUAGE Arrows, GADTs, TypeFamilies, NoImplicitPrelude, RankNTypes #-}
module ArrTest where

import Unsafe.Coerce
import CLaSH.Prelude hiding (id,(.))
import Control.Arrow
import Control.Category
import Data.Proxy

type family En a
type instance En Int   = Bool
type instance En Integer = Bool
type instance En (a,b) = (En a,En b)

--class En a where
--  data Ena a
--  toB   :: Ena a -> Bool
--  fromB :: Bool -> Ena a

--instance En Int where
--  newtype Ena Int = TI Bool
--  toB (TI b) = b
--  fromB b = (TI b)

--instance (En a,En b) => En (a,b) where
--  newtype Ena (a,b) = TTup {unTup :: (Ena a, Ena b)}
--  toB (TTup (a,_))  = toB a
--  fromB b           = TTup (fromB b, fromB b)

--coerceEn :: (forall a b . (En a, En b) => Ena a -> Ena b)
--coerceEn = fromB . toB

--type family Enba a where
--  Enba (a,b) = (Enba a, Enba b)
--  Enba a     = Bool

data SEn a where
  SEn  :: SEn a
  STup :: SEn a -> SEn b -> SEn (a,b)

data ArrowD b c where
  Id     :: ArrowD b b
  Seq    :: ArrowD c d -> ArrowD b c -> ArrowD b d
  Arr    :: (En c -> En b) -> (b -> c) -> ArrowD b c
  First  :: ArrowD b c -> ArrowD (b,d) (c,d)
  Second :: ArrowD b c -> ArrowD (d,b) (d,c)
  Split  :: ArrowD b c -> ArrowD b' c' -> ArrowD (b,b') (c,c')
  Fanout :: ArrowD b c -> ArrowD b c' -> ArrowD b (c,c')

instance Category ArrowD where
  id  = Id
  (.) = Seq

instance Arrow ArrowD where
  arr    = Arr unsafeCoerce
  first  = First
  second = Second
  (***)  = Split
  (&&&)  = Fanout

toBP :: ArrowD b c -> (Signal b -> Signal (En c) -> (Signal c,Signal (En b)))
toBP Id         = \b bEn -> (b,bEn)
toBP (Arr cv f) = \b bEn -> (fmap f b,fmap cv bEn)
toBP (Seq g f)  = \b dEn -> let (c,cEn) = toBP f b bEn
                                (d,bEn) = toBP g c dEn
                            in  (d,cEn)
toBP (First f) = \bd bdEn -> let (b,d)     = unbundle' bd
                                 (bEn,dEn) = unbundle' bdEn
                                 (c,cEn)   = toBP f b bEn
                             in (bundle' (c,d), (bundle' (cEn,dEn)))
toBP (Split f g) = \bb' en -> let (b,b')     = unbundle' bb'
                                  (bEn,bEn') = unbundle' en
                                  (c,cEn)    = toBP f b bEn
                                  (c',cEn')  = toBP g b' bEn'
                              in  (bundle' (c,c'),bundle' (cEn,cEn'))

topEntity :: Signal (Int,Int) -> Signal Bool -> (Signal Int,Signal (Bool,Bool))
topEntity = toBP (Seq (Arr dup (uncurry (+))) (Split (Arr id (*3)) (Arr id (*7))))

dup a = (a,a)