tuple-th 0.1 → 0.2.1
raw patch · 3 files changed
+101/−15 lines, 3 filesdep +containersdep ~base
Dependencies added: containers
Dependency ranges changed: base
Files
- TupleTH.hs +77/−12
- tests/Test.hs +22/−1
- tuple-th.cabal +2/−2
TupleTH.hs view
@@ -9,7 +9,7 @@ -- * Types htuple, -- * Transformation- mapTuple, mapTuple', filterTuple, filterTuple', reindexTuple, reverseTuple, rotateTuple, + mapTuple, mapTuple', filterTuple, filterTuple', reindexTuple, reverseTuple, rotateTuple, subtuples, deleteAtTuple, -- * Combination zipTuple, catTuples,uncatTuple, -- ** ZipWith@@ -18,13 +18,13 @@ safeTupleFromList, tupleFromList, constTuple, -- * Deconstruction proj, elemTuple, tupleToList, sumTuple,- -- ** Right folds+ -- ** Right folds foldrTuple, foldrTuple', foldr1Tuple, foldr1Tuple', - -- ** Left folds+ -- ** Left folds foldlTuple, foldlTuple', foldl1Tuple, foldl1Tuple', - -- ** Predicates+ -- ** Predicates andTuple, orTuple, anyTuple, anyTuple', allTuple, allTuple',@@ -35,9 +35,11 @@ import Language.Haskell.TH import Data.Maybe import Data.Functor-import Data.List()+import Data.List import Control.Monad import Control.Applicative+import Control.Exception+import Data.Set as Set -- | Makes a homogenous tuple type of the given size and element type @@ -55,13 +57,22 @@ newNames :: String -> Int -> Q [Name] newNames stem n = sequence [newName (stem++show i) | i <- [ 1::Int .. n ]] -withNames :: String -> Int -> (PatQ -> [ExpQ] -> Q b) -> Q b-withNames stem n body = do+withNames :: String -> Int -> (PatQ -> [ExpQ] -> Q a) -> Q a+withNames stem n body = withNames' stem n (body . tupP)++withNames' :: String -> Int -> ([PatQ] -> [ExpQ] -> Q a) -> Q a+withNames' _ n _ | n < 0 = fail ("Negative tuple size: "++show n)+withNames' stem n body = do names <- newNames stem n - body (tupP (fmap varP names)) (fmap varE names)+ body (fmap varP names) (fmap varE names) -withNames2 :: String-> String-> Int-> (PatQ -> [ExpQ] -> PatQ -> [ExpQ] -> Q b)-> Q b+withNames2+ :: String+ -> String+ -> Int+ -> (PatQ -> [ExpQ] -> PatQ -> [ExpQ] -> Q a)+ -> Q a withNames2 stem1 stem2 n body = withNames stem1 n (\xsp xes -> withNames stem2 n (body xsp xes)) @@ -276,7 +287,7 @@ -- | @reindexTuple n js@ creates the function ----- > \(x_0, ..., x_{n-1}) -> (x_{js !! 0}, x_{js !! 1}, .. x_{last js})+-- > \(x_0, ..., x_{n-1}) -> (x_{js !! 0}, x_{js !! 1}, ... x_{last js}) -- -- For example, --@@ -284,10 +295,16 @@ -- -- Each element of @js@ must be nonnegative and less than @n@. reindexTuple :: Int -> [Int] -> Q Exp-reindexTuple n is = withxs n (\xsp xes ->- lam1E xsp (tupE (fmap (xes !!) is)))+reindexTuple n is = withNames' "x" n (\xps xes ->+ let+ iset = Set.fromList is+ xsp' = fmap (\(p,i) -> if i `member` iset then p else wildP) + (zip xps [0..]) + in+ lam1E (tupP xsp') (tupE (fmap (xes !!) is))) + -- | Like 'reverse'. reverseTuple :: Int -> Q Exp reverseTuple n = reindexTuple n (reverse [0..n-1])@@ -324,7 +341,23 @@ [| $(conE $ tupleDataName n) <$> $(head xes) |] (tail xes))) +descendingMultiindices :: Int -> Int -> [[Int]]+descendingMultiindices _ 0 = [[]] +descendingMultiindices n 1 = fmap (:[]) [0..n-1] +descendingMultiindices n k | k < 0 = error ("Internal error in tuple-th: descendingMultiindices "++show n++" "++show k)+descendingMultiindices n k = [ i:is | is <- descendingMultiindices (n-1) (k-1),+ i <- [head is+1,head is+2 .. n-1] ] ++-- | Generates the function which maps a tuple @(x_1, ..., x_n)@ to the tuple of all its subtuples of the form @(x_{i_1}, ..., x_{i_k})@, where @i_1 < i_2 < ... < i_k@.+subtuples :: Int -> Int -> Q Exp+subtuples n k = withxs n (\xsp xes ->+ let+ subtupleE :: [Int] -> ExpQ+ subtupleE = tupE . fmap (xes !!) + in+ lam1E xsp (tupE (fmap (subtupleE . reverse) (descendingMultiindices n k))))+ -- class Tuple as a | as -> a where -- filterTuple :: (a -> Bool) -> as -> [a] -- @@ -341,3 +374,35 @@ -- [valD (varP 'filterTuple) (normalB (filterTuple n)) []] -- ] -- +++-- | Generates a function which takes a 'Num' @i@ and a homogenous tuple of size @n@ and deletes the @i@-th (0-based) element of the tuple. +deleteAtTuple :: Int -> Q Exp+deleteAtTuple n = do+ i <- newName "i"+ lam1E (varP i) $ + withxs n (\xsp xes ->++ let+ matches0 = [ match + (litP (integerL j)) + (normalB . tupE . deleteAt j $ xes)+ []+ | j <- [0 .. fromIntegral n -1] ]++ errmsg1 = "deleteAtTuple "++show n++" "+ errmsg2 = ": index out of bounds"++ matches = matches0 ++ [ + match wildP (normalB + [| error (errmsg1 ++ show $(varE i) ++ errmsg2) |])+ [] ] + in+ lam1E xsp $ caseE (varE i) matches)+++ where+ deleteAt 0 (_:xs) = xs+ deleteAt i (x:xs) = x : deleteAt (i-1) xs+ deleteAt _ _ = assert False undefined+
tests/Test.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, NoMonomorphismRestriction, ScopedTypeVariables #-}-{-# OPTIONS_GHC -ddump-splices -Wall #-}+{-# OPTIONS_GHC -ddump-splices -Wall -fno-warn-name-shadowing #-} + import TupleTH import Test.QuickCheck.All import Data.Char+import Test.QuickCheck.Property prop_foldrTuple :: (Int, Int, Int) -> Bool prop_foldrTuple t@(x::Int,y,z) = $(foldrTuple 3) (:) [] t == [x,y,z]@@ -35,7 +37,26 @@ prop_elemTuple :: Int -> Int -> Int -> Int -> Int -> Bool prop_elemTuple (x::Int) a b c d = $(elemTuple 4) x (a,b,c,d) == elem x [a,b,c,d] +prop_reindexTuple :: Int -> Int -> Int -> Bool prop_reindexTuple (x::Int) y z = $(reindexTuple 3 [1,1,0,0]) (x,y,z) == (y,y,x,x)++prop_deleteAtTuple :: Int -> Int -> Int -> Property+prop_deleteAtTuple x y z = + (deleteAtTuple3 0 t == (y,z) )+ .&. (deleteAtTuple3 1 t == (x,z) )+ .&. (deleteAtTuple3 2 t == (x,y) )+ where+ t = (x,y,z)+++deleteAtTuple3 :: Integer -> (Int,Int,Int) -> (Int,Int)+deleteAtTuple3 = $(deleteAtTuple 3)++prop_deleteAtTuple_oob1 :: Property+prop_deleteAtTuple_oob1 = expectFailure (deleteAtTuple3 (-1) (1,2,3) `seq` True)+prop_deleteAtTuple_oob2 :: Property+prop_deleteAtTuple_oob2 = expectFailure (deleteAtTuple3 3 (1,2,3) `seq` True)+ main :: IO Bool main = $(quickCheckAll)
tuple-th.cabal view
@@ -1,5 +1,5 @@ Name: tuple-th-Version: 0.1+Version: 0.2.1 Synopsis: Generate (non-recursive) utility functions for tuples of statically known size Description: Template Haskell functions for generating functions similar to those in Data.List for tuples of statically known size. License: BSD3@@ -14,6 +14,6 @@ Library Exposed-modules: TupleTH - Build-depends: base >= 4 && < 5, template-haskell+ Build-depends: base >= 4 && < 5, template-haskell, containers