{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
module Dyna.BackendK3.AST where
------------------------------------------------------------------------}}}
-- Preliminaries {{{
+ -- XXX
newtype VarIx = Var String
+ -- XXX (Hostname,Port)
newtype AddrIx = Addr (String,Int)
+ -- XXX should really do something smarter
data Ann = Ann [String]
------------------------------------------------------------------------}}}
tColl :: CollTy c -> r a -> r (CTE c a)
tFun :: r a -> r b -> r (a -> b)
- -- tTuple :: (RTupled rt, RTR rt ~ r) => rt -> r (RTE rt)
-- XXX TUPLES
+ -- tTuple :: (RTupled rt, RTR rt ~ r) => rt -> r (RTE rt)
tTuple2 :: (r a, r b) -> r (a,b)
tTuple3 :: (r a, r b, r c) -> r (a,b,c)
tTuple4 :: (r a, r b, r c, r d) -> r (a,b,c,d)
- -- | Existential typeclass wrapper for K3Ty
+ -- | Universal typeclass wrapper for K3Ty
newtype UnivTyRepr (a :: *) = UTR { unUTR :: forall r . (K3Ty r) => r a }
instance K3Ty UnivTyRepr where
tTuple3 us = UTR $ tTuple3 $ tupleopRS unUTR us
tTuple4 us = UTR $ tTuple4 $ tupleopRS unUTR us
-
-- | A constraint for "base" types in K3. These are the things that can
-- be passed to lambdas. Essentially everything other than arrows.
class K3BaseTy a
-- | Kinds of patterns permitted in K3
data PKind where
PKVar :: k -> PKind
+
+ -- | Just patterns (fail on Nothing)
+ --
+ -- Note the distinction between PatTy and (PatBTy and PatReprFn) here!
+ -- This pattern witnesses a type "Maybe a" but binds a variable of type
+ -- "a". This will in general be true of any variant (i.e. sum) pattern.
PKJust :: PKind -> PKind
- -- XXX TUPLES
- PKTuple2 :: (PKind, PKind) -> PKind
- PKTuple3 :: (PKind, PKind, PKind) -> PKind
- PKTuple4 :: (PKind, PKind, PKind, PKind) -> PKind
- -- PKTup :: [PKind] -> PKind
+ -- | Pair patterns
+ --
+ -- Product patterns, on the other hand, have PatTy and PatReprFn both
+ -- producing tuples.
+ PKTup :: [PKind] -> PKind
-- | Provides witnesses that certain types may be used
-- as arguments to K3 lambdas. Useful when building
-- eLam (PVar $ tPair tInt tInt) :: (r (Int, Int) -> _) -> _
-- eLam (PPair (PVar tInt) (PVar tInt)) :: ((r Int, r Int) -> _) -> _
--
-class Pat (w :: PKind) where
+class (UnPatDa (PatDa w) ~ w) => Pat (w :: PKind) where
-- | Any data this witness needs to carry around
data PatDa w :: *
-- | The type this witness witnesses (i.e. the things matched against)
-- | The type this witness binds (i.e. after matching is done)
type PatBTy w :: *
-- | The type of this pattern.
- type PatReprFn w (r :: * -> *) :: *
+ type PatReprFn (r :: * -> *) w :: *
+
+type family UnPatDa (pd :: *) :: PKind
+type instance UnPatDa (PatDa w) = w
instance (K3BaseTy a) => Pat (PKVar (a :: *)) where
data PatDa (PKVar a) = PVar { unPVar :: UnivTyRepr a }
type PatTy (PKVar a) = a
type PatBTy (PKVar a) = a
- type PatReprFn (PKVar a) r = r a
+ type PatReprFn r (PKVar a) = r a
instance (Pat w) => Pat (PKJust w) where
- -- | Just patterns (fail on Nothing)
- --
- -- Note the distinction between PatTy and (PatBTy and PatReprFn) here!
- -- This pattern witnesses a type "Maybe a" but binds a variable of type
- -- "a". This will in general be true of any variant (i.e. sum) pattern.
data PatDa (PKJust w) = PJust (PatDa w)
type PatTy (PKJust w) = Maybe (PatTy w)
type PatBTy (PKJust w) = PatBTy w
- type PatReprFn (PKJust w) r = PatReprFn w r
+ type PatReprFn r (PKJust w) = PatReprFn r w
-{-
-instance (Pat wa, Pat wb) => Pat (PKPair '(wa,wb)) where
- -- | Pair patterns
- --
- -- Product patterns, on the other hand, have PatTy and PatReprFn both
- -- producing tuples.
- data PatDa (PKPair '(wa,wb)) = PPair (PatDa wa) (PatDa wb)
- type PatTy (PKPair '(wa,wb)) = (PatTy wa, PatTy wb)
- type PatBTy (PKPair '(wa,wb)) = (PatBTy wa, PatBTy wb)
- type PatReprFn (PKPair '(wa,wb)) r = (PatReprFn wa r, PatReprFn wb r)
--}
+type family MapPatDa (x :: [PKind]) :: *
+$(mkTyMapFlat 0 ''MapPatDa ''PatDa)
- -- XXX TUPLES
-$( mapM (mkRecClass (''Pat,[]) (\n -> mkName $ "PKTuple" ++ show n)
- [(''PatDa,\n -> mkName $ "PTuple" ++ show n )]
- [''PatTy, ''PatBTy] [''PatReprFn])
- [2..4]
- )
+type family UnMapPatDa (x :: *) :: [PKind]
+$(mkTyUnMap 0 ''UnMapPatDa ''UnPatDa)
-{-
- -- Tragically patterns based on tuples are still represented
- -- in Haskell as right-branching, unit-ending.
-instance Pat (PKTup '[]) where
- data PatDa (PKTup '[]) = PTupN
- type PatTy (PKTup '[]) = ()
- type PatBTy (PKTup '[]) = ()
- type PatReprFn (PKTup '[]) r = r ()
-
-instance Pat (PKTup as) => Pat (PKTup (a ': as)) where
- data PatDa (PKTup (a ': as)) = PTupC (PatDa a) (PatDa (PKTup as))
- type PatTy (PKTup (a ': as)) = (PatTy a, PatTy (PKTup as))
- type PatBTy (PKTup (a ': as)) = (PatBTy a, PatBTy (PKTup as))
- type PatReprFn (PKTup (a ': as)) r = (PatReprFn a r, PatReprFn (PKTup as) r)
--}
+type family MapPatTy (x :: [PKind]) :: *
+$(mkTyMapFlat 0 ''MapPatTy ''PatTy)
+
+type family MapPatBTy (x :: [PKind]) :: *
+$(mkTyMapFlat 0 ''MapPatBTy ''PatBTy)
+
+type family MapPatReprFn (r :: * -> *) (x :: [PKind]) :: *
+$(mkTyMapFlat 1 ''MapPatReprFn ''PatReprFn)
+
+instance (ts ~ UnMapPatDa (MapPatDa ts))
+ => Pat (PKTup (ts :: [PKind])) where
+ data PatDa (PKTup ts) = PTup (MapPatDa ts)
+ type PatTy (PKTup ts) = MapPatTy ts
+ type PatBTy (PKTup ts) = MapPatBTy ts
+ type PatReprFn r (PKTup ts) = MapPatReprFn r ts
------------------------------------------------------------------------}}}
-- Slice System {{{
SKUnk :: k -> SKind
SKJust :: SKind -> SKind
- -- XXX TUPLES
- SKTuple2 :: (SKind, SKind) -> SKind
- SKTuple3 :: (SKind, SKind, SKind) -> SKind
- SKTuple4 :: (SKind, SKind, SKind, SKind) -> SKind
+ SKTup :: [SKind] -> SKind
-- | Witness of slice well-formedness
class Slice r (w :: SKind) where
data SliceDa w :: *
type SliceTy w :: *
+type family UnSliceDa (pd :: *) :: SKind
+type instance UnSliceDa (SliceDa w) = w
+
instance (K3BaseTy a, r0 ~ r) => Slice r0 (SKVar (r :: * -> *) (a :: *)) where
data SliceDa (SKVar r a) = SVar (r a)
type SliceTy (SKVar r a) = a
data SliceDa (SKJust s) = SJust (SliceDa s)
type SliceTy (SKJust s) = Maybe (SliceTy s)
-{-
-instance (Slice r sa, Slice r sb) => Slice r (SKTuple2 '(sa,sb)) where
- data SliceDa (SKTuple2 '(sa,sb)) = STuple2 (SliceDa sa) (SliceDa sb)
- type SliceTy (SKTuple2 '(sa,sb)) = (SliceTy sa, SliceTy sb)
--}
+type family SliceConst (x :: SKind) (r :: * -> *) :: Constraint
+type instance SliceConst x r = Slice r x
- -- XXX TUPLES
-$( mapM (mkRecClass (''Slice, [varT $ mkName "r"])
- (\n -> mkName $ "SKTuple" ++ show n)
- [(''SliceDa,\n -> mkName $ "STuple" ++ show n)]
- [''SliceTy] [])
- [2..4] )
+type family MapSliceConst (x :: [SKind]) (r :: * -> *) :: Constraint
+type instance MapSliceConst '[] r = ()
+type instance MapSliceConst (x ': xs) r = (SliceConst x r, MapSliceConst xs r)
+type family MapSliceDa (x :: [SKind]) :: *
+$(mkTyMapFlat 0 ''MapSliceDa ''SliceDa)
-{-
-instance Slice r (SKTup '[]) where
- data SliceDa (SKTup '[]) = STupN
- type SliceTy (SKTup '[]) = ()
+type family UnMapSliceDa (x :: *) :: [SKind]
+$(mkTyUnMap 0 ''UnMapSliceDa ''UnSliceDa)
-instance Slice r (SKTup as) => Slice r (SKTup (a ': as)) where
- data SliceDa (SKTup (a ': as)) = STupC (SliceDa a) (SliceDa (SKTup as))
- type SliceTy (SKTup (a ': as)) = (SliceTy a, SliceTy (SKTup as))
+type family MapSliceTy (x :: [SKind]) :: *
+$(mkTyMapFlat 0 ''MapSliceTy ''SliceTy)
+
+instance (ts ~ UnMapSliceDa (MapSliceDa ts), MapSliceConst ts r)
+ => Slice r (SKTup (ts :: [SKind])) where
+ data SliceDa (SKTup ts) = STup (MapSliceDa ts)
+ type SliceTy (SKTup ts) = MapSliceTy ts
--}
------------------------------------------------------------------------}}}
-- Numeric Autocasting {{{
-- Unlike traditional lambdas, we require a witness
-- that the argument is admissible in K3.
eLam :: (K3AST_Pat_C r w, Pat w, K3BaseTy (PatTy w))
- => PatDa w -> (PatReprFn w r -> r b) -> r (PatTy w -> b)
+ => PatDa w -> (PatReprFn r w -> r b) -> r (PatTy w -> b)
eApp :: r (a -> b) -> r a -> r b
eBlock :: [r ()] -> r a -> r a
-- Use as (eEmpty `asColl` CTSet)
asColl :: r (CTE c t) -> CollTy c -> r (CTE c t)
asColl = const
+
------------------------------------------------------------------------}}}
+
(tFun tInt $ tColl CTSet tInt)
$Just (eLam (PVar tInt) (\x -> eSing x))
-
testpairfn = Decl (Var "ibfst")
(tFun (tTuple2 (tInt,tBool)) tInt)
- $Just (eLam (PTuple2 (PVar tInt) (PVar tBool)) (\(a,b) -> a))
+ $Just (eLam (PTup (PVar tInt, PVar tBool)) (\(a,b) -> a))
lamslice = eLam (PVar autoty) $ \a ->
- eSlice (STuple2 (SVar a) (SVar (cInt 4)))
+ eSlice (STup (SVar a, SVar (cInt 4)))
(eSing (eTuple2 (cInt 3, cInt 4)) `asColl` CTSet)
-- XXX Man we need better tuple handling.
-project = eLam (PTuple2 (PVar autoty) (PVar autoty))
- $ \(x,c) -> eMap (eLam (PTuple3 (PVar autoty)
- (PVar autoty)
- (PVar autoty))
+project = eLam (PTup (PVar autoty, PVar autoty))
+ $ \(x,c) -> eMap (eLam (PTup (PVar autoty
+ ,PVar autoty
+ ,PVar autoty))
$ \(_,y,z) -> eTuple2 (y,z))
- (eSlice (STuple3 (SVar x) SUnk SUnk) c)
+ (eSlice (STup (SVar x, SUnk, SUnk)) c)
-proj' = eLam (PTuple3 (PVar tInt) (PVar tInt) (PVar tInt))
+proj' = eLam (PTup (PVar tInt, PVar tInt, PVar tInt))
$ \(a,b,c) -> b
-- Sum-Singleton case from M3ToK3 test
sumsing (ix :: r Int) (iy :: r Int) c1 c2 = eAdd (v c1) (v c2)
where
-- It is safe to eliminate this type signature
- si = STuple3 (SVar ix) (SVar iy) SUnk
+ si = STup (SVar ix,SVar iy,SUnk)
-- XXX unfortunately, we have to be explicit about the forall c1 here;
-- eliminating this type signature results in unified collection types
v c = eApp (eLam (PVar autoty)
(\cv -> macro_emptyPeek
cv (cInt 0)
- (\nec -> eApp (eLam (PTuple3 (PVar autoty)
- (PVar autoty)
- (PVar autoty))
+ (\nec -> eApp (eLam (PTup (PVar autoty
+ ,PVar autoty
+ ,PVar autoty))
$ \(_,_,proj) -> proj)
nec)))
(eSlice si c)
testjoin2 c1 c2 =
macro_simple_join2 pred c1 c2
- where p = PTuple3 (PVar tInt) (PVar tInt) (PVar tInt)
+ where p = PTup (PVar tInt, PVar tInt, PVar tInt)
pred = (eLam p (\(k1a,k2a,_) ->
eLam p (\(k1b,k2b,_) ->
(eEq k1a k1b) `eAdd` (eEq k2a k2b))))
+macro_localVar :: (K3 r, K3BaseTy a, K3AST_Pat_C r (PKVar a))
+ => UnivTyRepr a
+ -> (r a)
+ -> (r a -> r b)
+ -> r b
+macro_localVar w a b = eApp (eLam (PVar w) b) a
+
+testlocal = macro_localVar autoty
+ (eEmpty `asColl` CTBag)
+ (\x -> eInsert x $ eTuple2 (cInt 3, cInt 4))
+
------------------------------------------------------------------------}}}
-- Example cases: misc badness
module Dyna.BackendK3.Render where
+import Control.Monad.Identity
import Control.Monad.State
import Text.PrettyPrint.Free
import Dyna.XXX.MonadUtils
import Dyna.XXX.THTuple
+import qualified Language.Haskell.TH as TH
------------------------------------------------------------------------}}}
-- Type handling {{{
-- Pattern handling {{{
class (Pat w) => K3PFn w where
- k3pfn :: Bool -> PatDa w -> State Int (Doc e, PatReprFn w (AsK3 e))
+ k3pfn :: PatDa w -> State Int (Doc e, PatReprFn (AsK3 e) w)
instance (K3BaseTy a) => K3PFn (PKVar (a :: *)) where
- k3pfn _ (PVar tr) = do
+ k3pfn (PVar tr) = do
n <- incState
let sn = text $ "x" ++ show n
return (sn <> colon <> unAsK3Ty (unUTR tr)
,AsK3$ const$ sn)
instance (K3PFn w) => K3PFn (PKJust w) where
- k3pfn _ (PJust w) = do
- (p, r) <- k3pfn False w
+ k3pfn (PJust w) = do
+ (p, r) <- k3pfn w
return ("just " <> parens p, r)
- -- XXX TUPLES this should be automatically generated
-instance (K3PFn wa, K3PFn wb)
- => K3PFn (PKTuple2 '(wa,wb))
- where
- k3pfn _ (PTuple2 wa wb) = do
- (ba, ra) <- k3pfn False wa
- (bb, rb) <- k3pfn False wb
- return (tupled [ ba, bb ], (ra,rb))
-
-instance (K3PFn wa, K3PFn wb, K3PFn wc)
- => K3PFn (PKTuple3 '(wa,wb,wc))
- where
- k3pfn _ (PTuple3 wa wb wc) = do
- (ba, ra) <- k3pfn False wa
- (bb, rb) <- k3pfn False wb
- (bc, rc) <- k3pfn False wc
- return (tupled [ ba, bb, bc ], (ra,rb,rc))
-
-instance (K3PFn wa, K3PFn wb, K3PFn wc, K3PFn wd)
- => K3PFn (PKTuple4 '(wa,wb,wc,wd))
- where
- k3pfn _ (PTuple4 wa wb wc wd) = do
- (ba, ra) <- k3pfn False wa
- (bb, rb) <- k3pfn False wb
- (bc, rc) <- k3pfn False wc
- (bd, rd) <- k3pfn False wd
- return (tupled [ ba, bb, bc, bd ], (ra,rb,rc,rd))
-
-{-
-instance K3PFn (PKTup '[]) where
- k3pfn n _ PTupN = (n, rparen, AsK3$const$rparen)
-
-instance (Pat (PKTup as), K3PFn (PKTup as), K3PFn a)
- => K3PFn (PKTup (a ': as)) where
- k3pfn n b (PTupC a as) = let (n', pa, ra) = k3pfn n False a
- (n'', ps, rs) = k3pfn n' True as
- in (n'', extend pa ps, (ra,rs))
- where
- left = if b then comma else lparen
- extend pa ps = left <> pa <> ps
--}
-
------------------------------------------------------------------------}}}
-- Slice handling {{{
class (Slice (AsK3 e) w) => K3SFn e w where
- k3sfn :: Bool -> SliceDa w -> AsK3 e (SliceTy w)
+ k3sfn :: SliceDa w -> Identity (AsK3 e (SliceTy w))
instance (K3BaseTy a) => K3SFn e (SKVar (AsK3 e) (a :: *)) where
- k3sfn _ (SVar r) = r
+ k3sfn (SVar r) = return r
instance (K3BaseTy a) => K3SFn e (SKUnk (a :: *)) where
- k3sfn _ SUnk = AsK3$ const$ text "_"
+ k3sfn SUnk = return $ AsK3$ const$ text "_"
instance (K3SFn e s) => K3SFn e (SKJust s) where
- k3sfn _ (SJust s) = AsK3$ \n -> "Just" <> parens (unAsK3 (k3sfn False s) n)
-
- -- XXX TUPLES this should be automatically generated
-instance (K3SFn e sa, K3SFn e sb)
- => K3SFn e (SKTuple2 '(sa,sb))
- where
- k3sfn _ (STuple2 sa sb) =
- AsK3$ \n -> tupled [ unAsK3 (k3sfn False sa) n
- , unAsK3 (k3sfn False sb) n ]
-
-instance (K3SFn e sa, K3SFn e sb, K3SFn e sc)
- => K3SFn e (SKTuple3 '(sa,sb,sc))
- where
- k3sfn _ (STuple3 sa sb sc) =
- AsK3$ \n -> tupled [ unAsK3 (k3sfn False sa) n
- , unAsK3 (k3sfn False sb) n
- , unAsK3 (k3sfn False sc) n ]
-
-{-
-instance K3SFn e (SKTup '[]) where
- k3sfn _ STupN = AsK3$const$rparen
-
-instance (Slice (AsK3 e) (SKTup as), K3SFn e (SKTup as), K3SFn e a)
- => K3SFn e (SKTup (a ': as)) where
- k3sfn b (STupC a as) = AsK3$ \n -> left <> unAsK3 (k3sfn False a) n
- <> unAsK3 (k3sfn True as) n
- where
- left = if b then comma else lparen
--}
+ k3sfn (SJust s) = return $ AsK3$ \n -> "Just"
+ <> parens (unAsK3 (runIdentity $ k3sfn s) n)
+
------------------------------------------------------------------------}}}
-- Expression handling {{{
eLeq = binop "<="
eNeq = binop "!="
- eLam w f = AsK3$ \n -> let ((pat, arg),n') = runState (k3pfn False w) n
+ eLam w f = AsK3$ \n -> let ((pat, arg),n') = runState (k3pfn w) n
in align ("\\" <> pat <+> "->" `above` unAsK3 (f arg) n')
eApp (AsK3 f) (AsK3 x) = AsK3$ \n ->
eSort (AsK3 c) (AsK3 f) = builtin "sort" [ c, f ]
ePeek (AsK3 c) = builtin "peek" [ c ]
- eSlice w (AsK3 c) = AsK3$ \n -> c n <> brackets (unAsK3 (k3sfn False w) n)
+ eSlice w (AsK3 c) = AsK3$ \n -> c n <> brackets (unAsK3 (runIdentity $ k3sfn w) n)
eInsert (AsK3 c) (AsK3 e) = builtin "insert" [ c, e ]
eDelete (AsK3 c) (AsK3 e) = builtin "delete" [ c, e ]
<> semi
------------------------------------------------------------------------}}}
-
+-- Template Haskell splices {{{
+
+$(mkLRecInstances (''K3PFn,[]) 'PKTup
+ ('k3pfn,'PTup,\ls -> TH.tupE [
+ TH.appE (TH.varE 'tupled)
+ $ TH.listE
+ $ map (TH.appE (TH.varE 'fst)) ls
+ , TH.tupE $ map (TH.appE (TH.varE 'snd)) ls
+ ]
+ ))
+
+$(do
+ e <- liftM TH.varT $ TH.newName "e"
+ n <- TH.newName "n"
+ mkLRecInstances (''K3SFn,[e]) 'SKTup
+ ('k3sfn,'STup,\ls ->
+ TH.appE (TH.conE 'AsK3)
+ $ TH.lamE [TH.varP n]
+ $ TH.appE (TH.varE 'tupled)
+ $ TH.listE
+ $ map (\l -> TH.appE (TH.appE (TH.varE 'unAsK3) l) (TH.varE n))
+ $ ls
+ ))
-- Header material {{{
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
-module Dyna.XXX.THTuple(Tupled(..),RTupled(..),mkRecClass
- ) where
+module Dyna.XXX.THTuple(
+ -- * Promoted-kind type functions for tuples and rtuples
+ MKLT(..),MKRLT(..),
+
+ -- * Classes on tuples and rtuples
+ Tupled(..),RTupled(..),
+
+ -- * Template Haskell utility functions for type-level
+ mkRecInstances, mkTyMap, mkTyMapFlat, mkTyUnMap,
+
+ -- * Template Haskell utility functions for data-level
+ mkLRecInstances
+) where
import Dyna.XXX.THTupleInternals
+------------------------------------------------------------------------}}}
+-- Type-level functions {{{
+
+type family MKLT (x :: [k]) :: k
+type instance MKLT '[] = ()
+type instance MKLT (a ': '[]) = a
+$(mkMKLTs ''MKLT)
+
+type family MKRLT (r :: k -> k') (x :: [k]) :: k'
+type instance MKRLT r '[] = ()
+type instance MKRLT r (a ': '[]) = r a
+$(mkMKRLTs ''MKRLT)
+
------------------------------------------------------------------------}}}
-- Exported classes {{{
-- which is invariant over the constructor in question
--
-- e.g. RTER (a,b) r = (r a, r b)
-class Tupled base where
+class (MKLT (TOL base) ~ base) => Tupled base where
-- | Apply r to each element of the tuple
type RTER base (r :: * -> *) :: *
+ -- | Go from the tuple representation to a promoted list;
+ -- the inverse of MKLT (as asserted by class constraints).
+ type TOL base :: [*]
+
-- | Shed a type constructor
tupleopR :: (RTupled rbase, (RTR rbase) ~ r, (RTE rbase) ~ base)
=> (forall x . r x -> x) -> rbase -> base
-- | Recover the constructor and base type from r-full tuples.
--
-- e.g. RTR (r a, r b) = r, RTE (r a, r b) = (a, b)
+ --
+ -- This class further specifies some equivalence properties
+ -- on RTER and MKRLT.
class (Tupled (RTE arred),
- RTER (RTE arred) (RTR arred) ~ arred)
+ RTER (RTE arred) (RTR arred) ~ arred,
+ MKRLT (RTR arred) (TOL (RTE arred)) ~ arred
+ )
=> RTupled arred where
type RTR arred :: (* -> *)
type RTE arred :: *
-- Aaaand action {{{
-- Generate instances for Tupled
-$(mkTupleInstances ''Tupled ''RTER 'tupleopR 'tupleopRS)
+$(mkTupleInstances ''Tupled ''RTER ''TOL 'tupleopR 'tupleopRS)
-- Generate instances for RTupled
$(mkRTupleInstances ''RTupled ''RTE ''RTR 'tupleopEL)
mkRTy n r = genMap appT (conT $ tupleTypeName n) (appT r . varT)
mkPTy n = genMap appT (promotedTupleT n) varT
+pcp x xs = promotedConsT `appT` x `appT` xs
+promoteList = foldr pcp promotedNilT
+
+------------------------------------------------------------------------}}}
+-- Make MKLT and MKRLT {{{
+
+mkMKLT :: Name -> Int -> Q Dec
+mkMKLT _mklt n = do
+ names <- mkNames n
+
+ tySynInstD _mklt [promoteList $ map varT names]
+ $ mkTy n names
+
+mkMKLTs t = foreachTupleSize (mkMKLT t)
+
+mkMKRLT :: Name -> Int -> Q Dec
+mkMKRLT _mklrt n = do
+ names <- mkNames n
+ vr <- liftM varT $ newName "r"
+
+ tySynInstD _mklrt [vr, promoteList $ map varT names]
+ $ mkRTy n vr names
+
+mkMKRLTs t = foreachTupleSize (mkMKRLT t)
+
+------------------------------------------------------------------------}}}
+-- Make type-level map functions {{{
+
+mkTyMap :: Int -> Name -> Name -> Q [Dec]
+mkTyMap nargs _ty _fn = do
+ let ty = conT _ty
+ let fn = conT _fn
+
+ args <- liftM (map varT) $ mkNames nargs
+
+ nil <- tySynInstD _ty (args++[promotedNilT]) promotedNilT
+
+ x <- liftM varT $ newName "x"
+ xs <- liftM varT $ newName "xs"
+ let afn = genMap appT fn id args
+ let aty = genMap appT ty id args
+
+ cons <- tySynInstD _ty (args++[pcp x xs]) $ pcp (afn `appT` x) (aty `appT` xs)
+ return [nil,cons]
+
+mkTyMapFlatN :: Int -> Name -> Name -> Int -> Q Dec
+mkTyMapFlatN nargs _ty _fn size = do
+ let ty = conT _ty
+ let fn = conT _fn
+ names <- mkNames size
+
+ args <- liftM (map varT) $ mkNames nargs
+ let afn = genMap appT fn id args
+
+ tySynInstD _ty (args++[promoteList $ map varT names])
+ $ genMap appT (conT $ tupleTypeName size)
+ (appT afn . varT)
+ names
+
+ -- | The composition of MKLT a mkTyMap result.
+mkTyMapFlat a b c = foreachTupleSize (mkTyMapFlatN a b c)
+
+mkTyUnMapN :: Int -> Name -> Name -> Int -> Q Dec
+mkTyUnMapN nargs _ty _fn size = do
+ let ty = conT _ty
+ let fn = conT _fn
+ names <- mkNames size
+
+ args <- liftM (map varT) $ mkNames nargs
+ let afn = genMap appT fn id args
+
+ tySynInstD _ty (args++[mkTy size names])
+ $ promoteList $ map (appT afn . varT) names
+
+mkTyUnMap a b c = foreachTupleSize (mkTyUnMapN a b c)
+
------------------------------------------------------------------------}}}
-- Make Tuple {{{
-mkTupleInstance :: Name -> Name -> Name -> Name -> Int -> Q Dec
-mkTupleInstance _tc _rter _opr _oprs n | n > 1 = do
+mkTupleInstance :: Name -> Name -> Name -> Name -> Name -> Int -> Q Dec
+mkTupleInstance _tc _rter _tol _opr _oprs n | n > 1 = do
-- Build polymorphic variables
names <- mkNames n
-- The constructor and function argument
vr <- liftM varT $ newName "r"
- vf <- newName "f"
-
- -- Derive the rtuple type
- let rty = mkRTy n vr names
+ f <- newName "f"
-- Patterns and expressions
- let fnames = map (appE (varE vf) . varE) names
+ let fnames = map (appE (varE f) . varE) names
let rpa = tupP $ map varP names
let frpa = foldl appE (conE $ tupleDataName n) fnames
instanceD (cxt []) (appT (conT _tc) ty) -- where
- [tySynInstD _rter [ty, vr] rty
- ,funD _opr [clause [varP vf, rpa] (normalB $ frpa) [] ]
- ,funD _oprs [clause [varP vf, rpa] (normalB $ frpa) [] ]
+ [tySynInstD _rter [ty, vr] $ mkRTy n vr names
+ ,tySynInstD _tol [ty] $ promoteList $ map varT names
+ ,funD _opr [clause [varP f, rpa] (normalB $ frpa) [] ]
+ ,funD _oprs [clause [varP f, rpa] (normalB $ frpa) [] ]
]
-mkTupleInstances a b c d = foreachTupleSize (mkTupleInstance a b c d)
+mkTupleInstances a b c d e = foreachTupleSize (mkTupleInstance a b c d e)
------------------------------------------------------------------------}}}
-- Make RTuple {{{
mkRTupleInstance :: Name -> Name -> Name -> Name -> Int -> Q Dec
mkRTupleInstance _tc _rte _rtr _opel n | n > 1 = do
names <- mkNames n
- vr <- liftM varT $ newName "r"
- vf <- newName "f"
+
+ -- i.e. "r :: * -> *"
+ vr <- fmap (flip sigT (ArrowT `AppT` StarT `AppT` StarT) . varT)
+ $ newName "r"
+ f <- newName "f"
let rty = mkRTy n vr names
- let fnames = map (appE (varE vf) . varE) names
+ let fnames = map (appE (varE f) . varE) names
let rpa = tupP $ map varP names
let lfrpa = listE fnames
instanceD (cxt []) (appT (conT _tc) rty) -- where
[tySynInstD _rtr [rty] vr
,tySynInstD _rte [rty] $ mkTy n names
- ,funD _opel [clause [varP vf, rpa] (normalB $ lfrpa) [] ]
+ ,funD _opel [clause [varP f, rpa] (normalB $ lfrpa) [] ]
]
mkRTupleInstances a b c d = foreachTupleSize (mkRTupleInstance a b c d)
-- XXX TUPLES Can't yet generate the closed lifted-ADTs we use
-- for class heads.
-mkRecClass :: (Name, [TypeQ]) -- ^ Class name and threaded arguments
- -> (Int -> Name) -- ^ Class argument maker
- -> [(Name,Int -> Name)] -- ^ Datas and constructor-maker
- -> [Name] -- ^ Types
- -> [Name] -- ^ Types with constructor argument
- -> Int -- ^ Tuple size
- -> Q Dec
-mkRecClass (_cname,_cargs) _ntyf _dnames _tnames _trnames n = do
+mkRecInstance :: (Name, [TypeQ]) -- ^ Class name and threaded arguments
+ -> (Int -> Name) -- ^ Instance argument maker
+ -> [(Name,Int -> Name)] -- ^ Datas and constructor-maker
+ -> [Name] -- ^ Types
+ -> [Name] -- ^ Types with constructor argument
+ -> Int -- ^ Tuple size
+ -> Q Dec
+mkRecInstance (_cname,_cargs) _ntyf _dnames _tnames _trnames n = do
names <- mkNames n
let _tyf = _ntyf n
let context = cxt $ map (\na -> classP _cname $ _cargs ++ [varT na]) names
let conarg = (appT (conT _tyf) $ mkPTy n names)
- let datas :: [DecQ]
- datas = map (\(tc,ndc) -> dataInstD (cxt []) tc [conarg]
+ let datas = map (\(tc,ndc) -> dataInstD (cxt []) tc [conarg]
[normalC (ndc n) $ map (strictType (return NotStrict)
. appT (conT tc) . varT)
names]
_tnames
vr <- liftM varT $ newName "r"
- let rtypes = map (\tc -> tySynInstD tc ([conarg] ++ [vr])
+ let rtypes = map (\tc -> tySynInstD tc (vr:conarg:[])
$ genMap appT (conT $ tupleTypeName n)
- (\na -> appT (appT (conT tc) (varT na)) vr)
+ (appT (appT (conT tc) vr) . varT)
names)
_trnames
(genMap appT (conT _cname) (id) $ _cargs ++ [conarg])
$ concat [datas,types,rtypes]
+mkRecInstances a b c d e = foreachTupleSize (mkRecInstance a b c d e)
+
+mkLRecInstance :: (Name, [TypeQ]) -- ^ Class name and args
+ -> Name
+ -> (Name, Name, [ExpQ] -> ExpQ) -- ^ Function, data, and body
+ -> Int -- ^ Tuple size
+ -> Q Dec
+mkLRecInstance (_cname,_cargs) _tyf (_fn,_fpn,fm) n = do
+ names <- mkNames n
+ let context = cxt $ map (\na -> classP _cname $ _cargs ++ [varT na]) names
+ let conarg = (appT (conT _tyf) $ promoteList $ map varT names)
+
+ resnames <- mkNames n
+
+ let stmts = zipWith (\a ra -> bindS (varP ra) (appE (varE _fn) (varE a)))
+ names resnames
+ let res = noBindS $ appE (varE $ mkName "return") $ fm $ map varE resnames
+
+ instanceD context (genMap appT (conT _cname) (id) $ _cargs ++ [conarg])
+ [funD _fn [clause [conP _fpn [tupP $ map varP names]]
+ (normalB $ doE $ stmts++[res])
+ []
+ ]
+ ]
+
+mkLRecInstances a b c = foreachTupleSize (mkLRecInstance a b c)
+
------------------------------------------------------------------------}}}
-- Experimental detritus (XXX) {{{
projects / dyna2 / commitdiff