module Data.DDeepArrow
(
DArrow(..), DVal(..)
) where
#if __GLASGOW_HASKELL__ >= 609
import Control.Category
import Prelude hiding ((.), id)
#endif
import Control.Arrow
#if __GLASGOW_HASKELL__ < 610
hiding (pure)
#endif
import Language.Haskell.Syntax
import Data.Zip (Zip(..))
import Language.Haskell.ToHs
import Control.Arrow.DeepArrow
import Data.FunArr
data DArrow :: * -> * -> * where
Arr :: DVal (a -> b) -> a `DArrow` b
Compose :: a `DArrow` b -> b `DArrow` c -> a `DArrow` c
First :: a `DArrow` a' -> (a,b) `DArrow` (a',b)
Second :: b `DArrow` b' -> (a,b) `DArrow` (a,b')
Result :: b `DArrow` b' -> (a -> b) `DArrow` (a -> b')
FunF :: (c -> a,b) `DArrow` (c -> (a,b))
FunS :: (a,c -> b) `DArrow` (c -> (a,b))
FunR :: (a -> c -> b) `DArrow` (c -> a -> b)
CurryA :: ((a,b) -> c) `DArrow` (a -> b -> c)
UncurryA :: (a -> b -> c) `DArrow` ((a,b) -> c)
LAssocA :: (a,(b,c)) `DArrow` ((a,b),c)
RAssocA :: ((a,b),c) `DArrow` (a,(b,c))
IdA :: a `DArrow` a
DupA :: a `DArrow` (a,a)
FstA :: (a,b) `DArrow` a
SndA :: (a,b) `DArrow` b
SwapA :: (a,b) `DArrow` (b,a)
#if __GLASGOW_HASKELL__ >= 609
instance Category DArrow where
id = IdA
(.) = flip Compose
#endif
instance Arrow DArrow where
arr = error "no arr/pure for DDeepArrow"
#if __GLASGOW_HASKELL__ < 609
(>>>) = Compose
#endif
first = First
second = Second
instance DeepArrow DArrow where
result = Result
funF = FunF
funS = FunS
funR = FunR
curryA = CurryA
uncurryA = UncurryA
lAssocA = LAssocA
rAssocA = RAssocA
dupA = DupA
fstA = FstA
sndA = SndA
swapA = SwapA
data DVal :: * -> * where
ExpDV :: HsExp -> DVal a
AppDA :: a `DArrow` b -> DVal a -> DVal b
ZipDV :: DVal a -> DVal b -> DVal (a,b)
instance Zip DVal where zip = ZipDV
instance ToHsExp (DArrow a b) where
toHsExp (Arr dvFun) = toHsExp dvFun
toHsExp (Compose ab bc) = toHsInfix (HsSymbol ">>>") ab bc
toHsExp (First f) = toHsApp1 "first" f
toHsExp (Second f) = toHsApp1 "second" f
toHsExp (Result f) = toHsApp1 "result" f
toHsExp FunF = varid "funF"
toHsExp FunS = varid "funS"
toHsExp FunR = varid "funR"
toHsExp CurryA = varid "curryA"
toHsExp UncurryA = varid "uncurryA"
toHsExp LAssocA = varid "lAssocA"
toHsExp RAssocA = varid "rAssocA"
toHsExp IdA = varid "idA"
toHsExp DupA = varid "dupA"
toHsExp FstA = varid "fstA"
toHsExp SndA = varid "sndA"
toHsExp SwapA = varid "swapA"
instance ToHsExp (DVal a) where
toHsExp (ExpDV expr) = expr
toHsExp (AppDA ar dv) = toHsExp ar `HsApp` toHsExp dv
toHsExp (ZipDV a b) = HsTuple [toHsExp a, toHsExp b]
instance FunArr DArrow DVal where
toArr = Arr
IdA $$ v = v
ar $$ v = AppDA ar v
instance Show (DArrow a b) where show = prettyAsHsExp
instance Show (DVal a) where show = prettyAsHsExp