adaptive-tuple 0.1.1 → 0.2.0

raw patch · 6 files changed

+152/−132 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• adaptive-tuple.cabal +1/−1
• src/Data/AdaptiveTuple.hs +16/−118
• src/Data/AdaptiveTuple/AdaptiveTuple.hs +67/−2
• src/Data/AdaptiveTuple/Reps/Lazy.hs +14/−2
• src/Data/AdaptiveTuple/Reps/Strict.hs +14/−2
• src/Data/AdaptiveTuple/TH.hs +40/−7

@@ -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.

@@ -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

@@ -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 

@@ -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)

@@ -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)

@@ -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