diff --git a/adaptive-tuple.cabal b/adaptive-tuple.cabal --- a/adaptive-tuple.cabal +++ b/adaptive-tuple.cabal @@ -1,5 +1,5 @@ name: adaptive-tuple -version: 0.1.1 +version: 0.2.0 synopsis: Self-optimizing tuple types description: Self optimizing tuple types. diff --git a/src/Data/AdaptiveTuple.hs b/src/Data/AdaptiveTuple.hs --- a/src/Data/AdaptiveTuple.hs +++ b/src/Data/AdaptiveTuple.hs @@ -25,13 +25,8 @@ -- using AdaptiveTuple is similar to the `ZipList` applicative instance, except -- without the overhead. -{-# LANGUAGE MultiParamTypeClasses, - FlexibleInstances, - FlexibleContexts, - ScopedTypeVariables, - Rank2Types, - GeneralizedNewtypeDeriving, - TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses + ,Rank2Types #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -50,23 +45,13 @@ where -import Prelude -import qualified Prelude as P - import Data.AdaptiveTuple.AdaptiveTuple import qualified Data.AdaptiveTuple.Reps.Lazy as L import qualified Data.AdaptiveTuple.Reps.Strict as S - -import Data.TypeLevel.Num +import Data.TypeLevel.Num as T -import Control.Arrow import Control.Applicative -import Control.Monad --- helper function -fI :: (Integral a, Num b) => a -> b -fI = fromIntegral - -- -------------------------------------------------- -- |Lazily convert a list of AdaptiveTuples into an AdaptiveTuple of lists. @@ -78,104 +63,17 @@ mapIndexed :: (AdaptiveTuple c s) => (Int -> a -> b) -> c s a -> c s b mapIndexed f a = f <$> toATuple [0..] <*> a ---reification function - --- |run a computation using a lazy AdaptiveTuple -reifyTuple :: forall el r. Int -> [el] -> (forall c s. (AdaptiveTuple c s, Nat s) => c s el -> r) -> r -reifyTuple 0 xs f = f (toATuple xs :: ATuple0 D0 el) -reifyTuple 1 xs f = f (toATuple xs :: L.ATuple1 D1 el) -reifyTuple 2 xs f = f (toATuple xs :: L.ATuple2 D2 el) -reifyTuple 3 xs f = f (toATuple xs :: L.ATuple3 D3 el) -reifyTuple 4 xs f = f (toATuple xs :: L.ATuple4 D4 el) -reifyTuple 5 xs f = f (toATuple xs :: L.ATuple5 D5 el) -reifyTuple 6 xs f = f (toATuple xs :: L.ATuple6 D6 el) -reifyTuple 7 xs f = f (toATuple xs :: L.ATuple7 D7 el) -reifyTuple 8 xs f = f (toATuple xs :: L.ATuple8 D8 el) -reifyTuple 9 xs f = f (toATuple xs :: L.ATuple9 D9 el) -reifyTuple 10 xs f = f (toATuple xs :: L.ATuple10 D10 el) -reifyTuple 11 xs f = f (toATuple xs :: L.ATuple11 D11 el) -reifyTuple 12 xs f = f (toATuple xs :: L.ATuple12 D12 el) -reifyTuple 13 xs f = f (toATuple xs :: L.ATuple13 D13 el) -reifyTuple 14 xs f = f (toATuple xs :: L.ATuple14 D14 el) -reifyTuple 15 xs f = f (toATuple xs :: L.ATuple15 D15 el) -reifyTuple 16 xs f = f (toATuple xs :: L.ATuple16 D16 el) -reifyTuple 17 xs f = f (toATuple xs :: L.ATuple17 D17 el) -reifyTuple 18 xs f = f (toATuple xs :: L.ATuple18 D18 el) -reifyTuple 19 xs f = f (toATuple xs :: L.ATuple19 D19 el) -reifyTuple 20 xs f = f (toATuple xs :: L.ATuple20 D20 el) -reifyTuple n xs f = reifyIntegral n $ \n' -> f (makeListTuple n' xs) - --- |run a computation using a strict AdaptiveTuple -reifyStrictTuple :: forall el r. Int -> [el] -> (forall c s. (AdaptiveTuple c s, Nat s) => c s el -> r) -> r -reifyStrictTuple 0 xs f = f (toATuple xs :: ATuple0 D0 el) -reifyStrictTuple 1 xs f = f (toATuple xs :: S.ATuple1 D1 el) -reifyStrictTuple 2 xs f = f (toATuple xs :: S.ATuple2 D2 el) -reifyStrictTuple 3 xs f = f (toATuple xs :: S.ATuple3 D3 el) -reifyStrictTuple 4 xs f = f (toATuple xs :: S.ATuple4 D4 el) -reifyStrictTuple 5 xs f = f (toATuple xs :: S.ATuple5 D5 el) -reifyStrictTuple 6 xs f = f (toATuple xs :: S.ATuple6 D6 el) -reifyStrictTuple 7 xs f = f (toATuple xs :: S.ATuple7 D7 el) -reifyStrictTuple 8 xs f = f (toATuple xs :: S.ATuple8 D8 el) -reifyStrictTuple 9 xs f = f (toATuple xs :: S.ATuple9 D9 el) -reifyStrictTuple 10 xs f = f (toATuple xs :: S.ATuple10 D10 el) -reifyStrictTuple 11 xs f = f (toATuple xs :: S.ATuple11 D11 el) -reifyStrictTuple 12 xs f = f (toATuple xs :: S.ATuple12 D12 el) -reifyStrictTuple 13 xs f = f (toATuple xs :: S.ATuple13 D13 el) -reifyStrictTuple 14 xs f = f (toATuple xs :: S.ATuple14 D14 el) -reifyStrictTuple 15 xs f = f (toATuple xs :: S.ATuple15 D15 el) -reifyStrictTuple 16 xs f = f (toATuple xs :: S.ATuple16 D16 el) -reifyStrictTuple 17 xs f = f (toATuple xs :: S.ATuple17 D17 el) -reifyStrictTuple 18 xs f = f (toATuple xs :: S.ATuple18 D18 el) -reifyStrictTuple 19 xs f = f (toATuple xs :: S.ATuple19 D19 el) -reifyStrictTuple 20 xs f = f (toATuple xs :: S.ATuple20 D20 el) -reifyStrictTuple n xs f = reifyIntegral n $ \n' -> f (makeListTuple n' xs) - --- ------------------------------------------------------- --- no-element tuple - -data ATuple0 s el = ATuple0 deriving (Eq, Show) - -instance Functor (ATuple0 D0) where - fmap _ _ = ATuple0 - -instance Applicative (ATuple0 D0) where - pure _ = ATuple0 - _ <*> _ = ATuple0 - -instance AdaptiveTuple ATuple0 D0 where - getIndex _ _ = oObExcp "getIndex" - setIndex _ _ _ = ATuple0 - mapIndex _ _ _ = ATuple0 - toATuple _ = ATuple0 - fromATuple _ = [] - sequenceAT _ = return ATuple0 - - --- |A ListTuple is a List with a type-level length. --- to be used when there isn't a more specific adaptive tuple defined -newtype Nat s => ListTuple s a = ListTuple {getListTuple :: [a]} - deriving (Eq, Functor, Show) - --- |Create a ListTuple -makeListTuple :: Nat s => s -> [a] -> ListTuple s a -makeListTuple s xs | toInt s P.< P.length xs = - error $ "input list to short to make ListTuple of length " ++ - (show $ toInt s) -makeListTuple s xs = ListTuple . P.take (toInt s) $ xs - -instance Nat s => Applicative (ListTuple s) where - pure = pureLT - a <*> b = ListTuple $ zipWith ($) (getListTuple a) (getListTuple b) - -pureLT :: forall s a. (Nat s) => a -> ListTuple s a -pureLT = ListTuple . replicate (toInt (undefined :: s)) +--default reification functions +reifyTuple :: + forall el r.Int + -> [el] + -> (forall c s.(AdaptiveTuple c s, T.Nat s) => c s el -> r) + -> r +reifyTuple = L.reifyTuple20 -instance forall s. (Nat s) => AdaptiveTuple ListTuple s where - getIndex z i = getListTuple z !! (fI i) - setIndex i el = ListTuple . uncurry (++) . ((++ [el]) *** P.drop 1) . - P.splitAt (fI i) . getListTuple - mapIndex f i = ListTuple . uncurry (++) . second (\(x:xs) -> f x : xs) . - P.splitAt (fI i) . getListTuple - toATuple = makeListTuple (undefined :: s) - fromATuple = getListTuple - sequenceAT = liftM ListTuple . sequence . getListTuple +reifyStrictTuple :: + forall el r.Int + -> [el] + -> (forall c s.(AdaptiveTuple c s, T.Nat s) => c s el -> r) + -> r +reifyStrictTuple = S.reifyTuple20 diff --git a/src/Data/AdaptiveTuple/AdaptiveTuple.hs b/src/Data/AdaptiveTuple/AdaptiveTuple.hs --- a/src/Data/AdaptiveTuple/AdaptiveTuple.hs +++ b/src/Data/AdaptiveTuple/AdaptiveTuple.hs @@ -1,11 +1,20 @@ -{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable #-} +{-# LANGUAGE + MultiParamTypeClasses + ,FlexibleInstances + ,ScopedTypeVariables + ,GeneralizedNewtypeDeriving + ,DeriveDataTypeable #-} module Data.AdaptiveTuple.AdaptiveTuple ( -- *Type classes AdaptiveTuple (..) -- *Types ,AdaptiveTupleException (..) - -- *Error functions + ,ATuple0 + ,ListTuple + -- *Functions + ,makeListTuple + -- **Error functions ,oObExcp ,insExcp ) @@ -16,7 +25,13 @@ import Data.Data import Control.Exception import Control.Applicative +import Control.Arrow +import Control.Monad +-- helper function +fI :: (Integral a, Num b) => a -> b +fI = fromIntegral + -- |Adaptive tuples: unboxed tuples of varying size. -- @s@ is a type-level indicator of the number of elements in the container. class (Nat s, Applicative (c s)) => AdaptiveTuple c s where @@ -44,4 +59,54 @@ insExcp :: a insExcp = throw ATupleInsufficientInput + +-- ------------------------------------- +-- basic adaptive tuple types + +-- |no-element tuple +data ATuple0 s el = ATuple0 deriving (Eq, Show) + +instance Functor (ATuple0 D0) where + fmap _ _ = ATuple0 + +instance Applicative (ATuple0 D0) where + pure _ = ATuple0 + _ <*> _ = ATuple0 + +instance AdaptiveTuple ATuple0 D0 where + getIndex _ _ = oObExcp "getIndex" + setIndex _ _ _ = ATuple0 + mapIndex _ _ _ = ATuple0 + toATuple _ = ATuple0 + fromATuple _ = [] + sequenceAT _ = return ATuple0 + +-- |A ListTuple is a List with a type-level length. +-- to be used when there isn't a more specific adaptive tuple defined +newtype Nat s => ListTuple s a = ListTuple {getListTuple :: [a]} + deriving (Eq, Functor, Show) + +-- |Create a ListTuple +makeListTuple :: Nat s => s -> [a] -> ListTuple s a +makeListTuple s xs | toInt s Prelude.< length xs = + error $ "input list to short to make ListTuple of length " ++ + (show $ toInt s) +makeListTuple s xs = ListTuple . take (toInt s) $ xs + +instance Nat s => Applicative (ListTuple s) where + pure = pureLT + a <*> b = ListTuple $ zipWith ($) (getListTuple a) (getListTuple b) + +pureLT :: forall s a. (Nat s) => a -> ListTuple s a +pureLT = ListTuple . replicate (toInt (undefined :: s)) + +instance forall s. (Nat s) => AdaptiveTuple ListTuple s where + getIndex z i = getListTuple z !! (fI i) + setIndex i el = ListTuple . uncurry (++) . ((++ [el]) *** drop 1) . + splitAt (fI i) . getListTuple + mapIndex f i = ListTuple . uncurry (++) . second (\(x:xs) -> f x : xs) . + splitAt (fI i) . getListTuple + toATuple = makeListTuple (undefined :: s) + fromATuple = getListTuple + sequenceAT = liftM ListTuple . sequence . getListTuple diff --git a/src/Data/AdaptiveTuple/Reps/Lazy.hs b/src/Data/AdaptiveTuple/Reps/Lazy.hs --- a/src/Data/AdaptiveTuple/Reps/Lazy.hs +++ b/src/Data/AdaptiveTuple/Reps/Lazy.hs @@ -2,7 +2,13 @@ -- necessary to import this module unless you need to construct -- custom reification functions. -{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell + ,MultiParamTypeClasses + ,FlexibleInstances + ,TypeSynonymInstances + ,Rank2Types + ,DeriveDataTypeable #-} + {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-matches #-} module Data.AdaptiveTuple.Reps.Lazy @@ -15,7 +21,7 @@ import Language.Haskell.TH (Strict (..)) import Control.Applicative -$(makeDatas NotStrict 20) +$(makeDatas NotStrict 1 20) $(deriveInstances ''ATuple1 ''D1) $(deriveInstances ''ATuple2 ''D2) $(deriveInstances ''ATuple3 ''D3) @@ -36,3 +42,9 @@ $(deriveInstances ''ATuple18 ''D18) $(deriveInstances ''ATuple19 ''D19) $(deriveInstances ''ATuple20 ''D20) + +$(makeReify 4) +$(makeReify 8) +$(makeReify 12) +$(makeReify 16) +$(makeReify 20) diff --git a/src/Data/AdaptiveTuple/Reps/Strict.hs b/src/Data/AdaptiveTuple/Reps/Strict.hs --- a/src/Data/AdaptiveTuple/Reps/Strict.hs +++ b/src/Data/AdaptiveTuple/Reps/Strict.hs @@ -3,7 +3,13 @@ -- It is usually not necessary to import this module except to make custom -- reification functions. -{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell + ,MultiParamTypeClasses + ,FlexibleInstances + ,TypeSynonymInstances + ,Rank2Types + ,DeriveDataTypeable #-} + {-# OPTIONS_GHC -funbox-strict-fields -fno-warn-unused-binds -fno-warn-unused-matches #-} module Data.AdaptiveTuple.Reps.Strict @@ -16,7 +22,7 @@ import Language.Haskell.TH (Strict (..)) import Control.Applicative -$(makeDatas IsStrict 20) +$(makeDatas IsStrict 1 20) $(deriveInstances ''ATuple1 ''D1) $(deriveInstances ''ATuple2 ''D2) $(deriveInstances ''ATuple3 ''D3) @@ -37,3 +43,9 @@ $(deriveInstances ''ATuple18 ''D18) $(deriveInstances ''ATuple19 ''D19) $(deriveInstances ''ATuple20 ''D20) + +$(makeReify 4) +$(makeReify 8) +$(makeReify 12) +$(makeReify 16) +$(makeReify 20) diff --git a/src/Data/AdaptiveTuple/TH.hs b/src/Data/AdaptiveTuple/TH.hs --- a/src/Data/AdaptiveTuple/TH.hs +++ b/src/Data/AdaptiveTuple/TH.hs @@ -1,10 +1,18 @@ -{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, DeriveDataTypeable #-} +{-# LANGUAGE + TemplateHaskell + ,MultiParamTypeClasses + ,FlexibleInstances + ,FlexibleContexts + ,RankNTypes + ,UndecidableInstances + ,DeriveDataTypeable #-} {-# OPTIONS_GHC -funbox-strict-fields -fno-warn-incomplete-patterns #-} module Data.AdaptiveTuple.TH ( makeDatas ,makeData + ,makeReify ,deriveInstances ,deriveFunctor ,deriveApplicative @@ -27,10 +35,35 @@ -- template type for Q Decls data T1 s a = T1 a --- |Generate "ATuple1" ... "ATupleN" -makeDatas :: Strict -> Int -> Q [Dec] -makeDatas strict n = liftM concat $ mapM (makeData strict) [1..n] +-- |Generate a reification function +makeReify :: Integer -> Q [Dec] +makeReify maxn = do + let fname = mkName $ "reifyTuple" ++ show maxn + let basedecl = [d| rf :: forall el r.Int -> [el] -> (forall c s. (AdaptiveTuple c s, T.Nat s) => c s el -> r) -> r; rf 0 xs f = f (toATuple xs :: T1 s el) |] + d <- basedecl + let [(SigD _fname typ), _] = d + let mkclause n = do + ([xsPat,fPat],[xsExp,fExp]) <- genPE 2 + let tupN = mkName $ "ATuple" ++ show n + let dN = mkName $ "D" ++ show n + let atName = [| undefined :: $(appT (appT (conT tupN) (conT dN)) (conT ''() )) |] + clause [litP (IntegerL n),xsPat,fPat] + (normalB [| $fExp (helper $atName $xsExp)|]) [] + let defclause = do + ([nPat,xsPat,fPat],[nExp,xsExp,fExp]) <- genPE 3 + clause [nPat,xsPat,fPat] + (normalB [| T.reifyIntegral $nExp (\n' -> $fExp (makeListTuple n' $xsExp))|]) [] + cls <- mapM mkclause [0..maxn] + defcl <- defclause + return [SigD fname typ, FunD fname (cls++[defcl])] +helper :: (AdaptiveTuple c s, T.Nat s) => c s x -> [el] -> c s el +helper _ = toATuple + +-- |Generate "ATupleN" ... "ATupleM" +makeDatas :: Strict -> Int -> Int -> Q [Dec] +makeDatas strict m n = liftM concat $ mapM (makeData strict) [m..n] + -- |Given a value n >1, create data value "ATupleN" makeData :: Strict -> Int -> Q [Dec] makeData strict n = do @@ -96,14 +129,14 @@ (pf &&& bf)) [0..n] let getClauses (NormalC name fields) = do (aP, aV) <- genPE (length fields) - ([eP],[eV]) <- genPE 1 + ([eP],[_eV]) <- genPE 1 let getPats n = [conP name aP, litP (integerL (fromIntegral n))] let getBody = normalB . (aV !!) let errC = clause [wildP, eP] (normalB [| oObExcp "getIndex" |]) [] c1 <- makeClauseOut (length fields - 1) getPats getBody return (c1 ++ [errC]) let setClauses (NormalC name fields) = do - ([elP,eP], [elV,eV]) <- genPE 2 + ([elP,eP], [elV,_eV]) <- genPE 2 (aP, aV) <- genPE (length fields) let getPats n = [litP (integerL (fromIntegral n)), elP, conP name aP] let getBody n = normalB $ appsE (conE name:replaceAt aV n elV) @@ -111,7 +144,7 @@ c1 <- makeClauseOut (length fields - 1) getPats getBody return (c1 ++ [errC]) let mapClauses (NormalC name fields) = do - ([fP,eP], [fV,eV]) <- genPE 2 + ([fP,eP], [fV,_eV]) <- genPE 2 (aP, aV) <- genPE (length fields) let getPats n = [fP, litP (integerL (fromIntegral n)), conP name aP] let getBody n = normalB $ appsE