From 327bb07e07ef1366e39ae38b06192847fd62f806 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Fri, 5 Oct 2012 19:22:02 -0400 Subject: [PATCH] Eliminate explicit tuple size from pattern and slice constructors --- src/Dyna/BackendK3/AST.hs | 140 +++++++++++++-------------- src/Dyna/BackendK3/Examples.hs | 38 +++++--- src/Dyna/BackendK3/Render.hs | 118 ++++++++--------------- src/Dyna/XXX/THTuple.hs | 46 ++++++++- src/Dyna/XXX/THTupleInternals.hs | 157 +++++++++++++++++++++++++------ 5 files changed, 299 insertions(+), 200 deletions(-) diff --git a/src/Dyna/BackendK3/AST.hs b/src/Dyna/BackendK3/AST.hs index 7b46704..2153bb8 100644 --- a/src/Dyna/BackendK3/AST.hs +++ b/src/Dyna/BackendK3/AST.hs @@ -17,6 +17,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Dyna.BackendK3.AST where @@ -29,9 +31,12 @@ import Dyna.XXX.THTuple ------------------------------------------------------------------------}}} -- Preliminaries {{{ + -- XXX newtype VarIx = Var String + -- XXX (Hostname,Port) newtype AddrIx = Addr (String,Int) + -- XXX should really do something smarter data Ann = Ann [String] ------------------------------------------------------------------------}}} @@ -90,14 +95,14 @@ class K3Ty (r :: * -> *) where 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 @@ -120,7 +125,6 @@ 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 @@ -142,13 +146,19 @@ instance (K3BaseTy a, K3BaseTy b, K3BaseTy c) => K3BaseTy (a,b,c) -- | 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 @@ -168,7 +178,7 @@ data PKind where -- 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) @@ -176,59 +186,44 @@ class Pat (w :: PKind) where -- | 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 {{{ @@ -239,16 +234,16 @@ data SKind where 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 @@ -261,30 +256,27 @@ instance (Slice r s) => Slice r (SKJust s) where 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 {{{ @@ -384,7 +376,7 @@ class K3 (r :: * -> *) where -- 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 @@ -452,4 +444,6 @@ data Decl tr r t = Decl VarIx (tr t) (Maybe (r t)) -- Use as (eEmpty `asColl` CTSet) asColl :: r (CTE c t) -> CollTy c -> r (CTE c t) asColl = const + ------------------------------------------------------------------------}}} + diff --git a/src/Dyna/BackendK3/Examples.hs b/src/Dyna/BackendK3/Examples.hs index 8ff29cd..0527a8d 100644 --- a/src/Dyna/BackendK3/Examples.hs +++ b/src/Dyna/BackendK3/Examples.hs @@ -75,24 +75,23 @@ testcfn = Decl (Var "cfn") (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 @@ -100,7 +99,7 @@ proj' = eLam (PTuple3 (PVar tInt) (PVar tInt) (PVar tInt)) 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 @@ -111,9 +110,9 @@ sumsing (ix :: r Int) (iy :: r Int) c1 c2 = eAdd (v c1) (v c2) 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) @@ -125,11 +124,22 @@ testSumsing = sumsing (cInt 4) (cInt 5) 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 diff --git a/src/Dyna/BackendK3/Render.hs b/src/Dyna/BackendK3/Render.hs index a11e949..6db50bf 100644 --- a/src/Dyna/BackendK3/Render.hs +++ b/src/Dyna/BackendK3/Render.hs @@ -15,6 +15,7 @@ module Dyna.BackendK3.Render where +import Control.Monad.Identity import Control.Monad.State import Text.PrettyPrint.Free @@ -22,6 +23,7 @@ import Dyna.BackendK3.AST import Dyna.XXX.MonadUtils import Dyna.XXX.THTuple +import qualified Language.Haskell.TH as TH ------------------------------------------------------------------------}}} -- Type handling {{{ @@ -83,104 +85,36 @@ instance K3CFn CBag where -- 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 {{{ @@ -231,7 +165,7 @@ instance K3 (AsK3 e) where 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 -> @@ -255,7 +189,7 @@ instance K3 (AsK3 e) where 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 ] @@ -306,4 +240,26 @@ shd (Decl (Var name) tipe body) = <> 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 + )) diff --git a/src/Dyna/XXX/THTuple.hs b/src/Dyna/XXX/THTuple.hs index 526b473..ec6203a 100644 --- a/src/Dyna/XXX/THTuple.hs +++ b/src/Dyna/XXX/THTuple.hs @@ -6,20 +6,47 @@ -- 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 {{{ @@ -27,10 +54,14 @@ import Dyna.XXX.THTupleInternals -- 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 @@ -43,8 +74,13 @@ class Tupled base where -- | 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 :: * @@ -56,7 +92,7 @@ class (Tupled (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) diff --git a/src/Dyna/XXX/THTupleInternals.hs b/src/Dyna/XXX/THTupleInternals.hs index d389d94..cd9fdc1 100644 --- a/src/Dyna/XXX/THTupleInternals.hs +++ b/src/Dyna/XXX/THTupleInternals.hs @@ -31,11 +31,87 @@ mkDa n = genMap appE (conE $ tupleDataName n) varE 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 @@ -44,23 +120,21 @@ mkTupleInstance _tc _rter _opr _oprs n | n > 1 = do -- 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 {{{ @@ -68,17 +142,20 @@ mkTupleInstances a b c d = foreachTupleSize (mkTupleInstance a b c d) 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) @@ -89,21 +166,20 @@ 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] @@ -117,9 +193,9 @@ mkRecClass (_cname,_cargs) _ntyf _dnames _tnames _trnames n = do _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 @@ -127,6 +203,33 @@ mkRecClass (_cname,_cargs) _ntyf _dnames _tnames _trnames n = do (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) {{{ -- 2.50.1