diff --git a/Data/Adaptive/List.hs b/Data/Adaptive/List.hs new file mode 100644 --- /dev/null +++ b/Data/Adaptive/List.hs @@ -0,0 +1,1981 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} + +-- | +-- Module : Data.Adaptive.List +-- Copyright : (c) Duncan Coutts 2007 +-- (c) Don Stewart 2007 .. 2009 +-- License : BSD-style +-- Maintainer : dons@galois.com +-- Stability : experimental +-- +-- Self adapting polymorphic lists. +-- +-- This library statically specializes the polymorphic container +-- representation of lists to specific, more efficient representations, +-- when instantiated with particular monomorphic types. It does this via +-- an associated more efficient data type for each pair of elements you +-- wish to store in your container. +-- +-- The resulting list structures use less space, and functions on them tend to +-- be faster, than regular lists. +-- +-- Instead of representing '[1..5] :: [Int]' as: +-- +-- > (:) +-- > / \ +-- > / \ +-- > I# 1# (:) +-- > / \ +-- > / \ +-- > I# 2# (:) +-- > / \ +-- > / \ +-- > I# 3# [] +-- +-- The compiler will select an associated data type that packs better, +-- via the class instances, resulting in: +-- +-- > ConsInt 1# +-- > | +-- > ConsInt 2# +-- > | +-- > ConsInt 3# +-- > | +-- > [] +-- +-- The user however, still sees a polymorphic list type. +-- +-- This list type currently doesn't fuse. +-- +module Data.Adaptive.List where + +import Data.Adaptive.Tuple + +import qualified Prelude +import Prelude (Eq(..),Ord(..),Ordering(..), (.) + ,Int,Char,Float,Double,Integer,Bool(..),otherwise,(-)) +import Data.Int +import Data.Word + +-- * The adaptive list class-associated type +-- +-- | Representation-improving polymorphic lists. +-- +class AdaptList a where + + data List a + + -- | The empty list + empty :: List a + + -- | Prepend a value onto a list + cons :: a -> List a -> List a + + -- | Is the list empty? + null :: List a -> Bool + + -- | The first element of the list + head :: List a -> a + + -- | The tail of the list + tail :: List a -> List a + +------------------------------------------------------------------------ +-- * Basic Interface + +infixr 5 ++ +infixr 5 : +-- infix 5 \\ -- comment to fool cpp +-- infixl 9 !! +infix 4 `elem`, `notElem` + +-- | /O(n)/, convert an adaptive list to a regular list +toList :: AdaptList a => List a -> [a] +toList xs + | null xs = [] + | otherwise = head xs : toList (tail xs) + +-- | /O(n)/, convert an adaptive list to a regular list +fromList :: AdaptList a => [a] -> List a +fromList [] = empty +fromList (x:xs) = x `cons` fromList xs + +-- | /O(n)/, construct a list by enumerating a range +enumFromToList :: (AdaptList a, Ord a, Prelude.Enum a) => a -> a ->List a +enumFromToList x0 y + | x0 > y = empty + | otherwise = go x0 + where + go x = x `cons` if x == y then empty else go (Prelude.succ x) +{-# INLINE enumFromToList #-} + +-- | /O(1)/, uncons, take apart a list into the head and tail. +-- +uncons :: AdaptList a => List a -> Prelude.Maybe (a, List a) +uncons xs | null xs = Prelude.Nothing + | otherwise = Prelude.Just (head xs, tail xs) + +-- | /O(n)/, Append two lists, i.e., +-- +-- > [x1, ..., xm] ++ [y1, ..., yn] == [x1, ..., xm, y1, ..., yn] +-- > [x1, ..., xm] ++ [y1, ...] == [x1, ..., xm, y1, ...] +-- +-- If the first list is not finite, the result is the first list. +-- The spine of the first list argument must be copied. +-- +(++) :: AdaptList a => List a -> List a -> List a +(++) xs ys + | null xs = ys + | otherwise = head xs `cons` tail xs ++ ys + +-- | /O(n)/, Extract the last element of a list, which must be finite +-- and non-empty. +last :: AdaptList a => List a -> a +last xs + | null xs = errorEmptyList "last" + | otherwise = go (head xs) (tail xs) + where + go y z + | null z = y + | otherwise = go (head z) (tail z) +{-# INLINE last #-} + +-- | /O(n)/. Return all the elements of a list except the last one. +-- The list must be finite and non-empty. +init :: AdaptList a => List a -> List a +init xs + | null xs = errorEmptyList "init" + | otherwise = go (head xs) (tail xs) + where + go y z + | null z = empty + | otherwise = y `cons` go (head z) (tail z) +{-# INLINE init #-} + +-- | /O(n)/. 'length' returns the length of a finite list as an 'Int'. +-- It is an instance of the more general 'Data.List.genericLength', +-- the result type of which may be any kind of number. +length :: AdaptList a => List a -> Int +length xs0 = go xs0 0 + where + go :: AdaptList a => List a -> Int -> Int + go xs !a + | null xs = a + | otherwise = go (tail xs) (a Prelude.+ 1) +{-# INLINE length #-} + +-- --------------------------------------------------------------------- +-- * List transformations + +-- | /O(n)/. 'map' @f xs@ is the list obtained by applying @f@ to each element +-- of @xs@, i.e., +-- +-- > map f [x1, x2, ..., xn] == [f x1, f x2, ..., f xn] +-- > map f [x1, x2, ...] == [f x1, f x2, ...] +-- +-- Properties: +-- +-- > map f . map g = map (f . g) +-- > map f (repeat x) = repeat (f x) +-- > map f (replicate n x) = replicate n (f x) + +map :: (AdaptList a, AdaptList b) => (a -> b) -> List a -> List b +map f as = go as + where + go xs + | null xs = empty + | otherwise = f (head xs) `cons` go (tail xs) +{-# INLINE map #-} + +-- | /O(n)/. 'reverse' @xs@ returns the elements of @xs@ in reverse order. +-- @xs@ must be finite. Will fuse as a consumer only. +reverse :: AdaptList a => List a -> List a +reverse = foldl (Prelude.flip cons) empty +{-# INLINE reverse #-} + +-- | /O(n)/. The 'intersperse' function takes an element and a list and +-- \`intersperses\' that element between the elements of the list. +-- For example, +-- +-- > intersperse ',' "abcde" == "a,b,c,d,e" +-- +intersperse :: AdaptList a => a -> List a -> List a +intersperse sep zs + | null zs = empty + | otherwise = head zs `cons` go (tail zs) + where + go xs + | null xs = empty + | otherwise = sep `cons` (head xs `cons` go (tail xs)) +{-# INLINE intersperse #-} + +-- | /O(n)/. 'intercalate' @xs xss@ is equivalent to @('concat' ('intersperse' xs xss))@. +-- It inserts the list @xs@ in between the lists in @xss@ and concatenates the +-- result. +-- +-- > intercalate = concat . intersperse +-- +intercalate :: (AdaptList (List a), AdaptList a) + => List a -> List (List a) -> List a +intercalate sep xss = go (intersperse sep xss) + where + go ys + | null ys = empty + | otherwise = head ys ++ go (tail ys) +{-# INLINE intercalate #-} + +-- --------------------------------------------------------------------- +-- * Reducing lists (folds) + +-- | /O(n)/. 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a list, reduces the list +-- using the binary operator, from left to right: +-- +-- > foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn +-- +-- The list must be finite. The accumulator is whnf strict. +-- +foldl :: AdaptList b => (a -> b -> a) -> a -> List b -> a +foldl f z0 xs0 = go z0 xs0 + where + go !z xs + | null xs = z + | otherwise = go (f z (head xs)) (tail xs) +{-# INLINE foldl #-} + +-- | /O(n)/. 'foldl1' is a variant of 'foldl' that has no starting value argument, +-- and thus must be applied to non-empty lists. +foldl1 :: AdaptList a => (a -> a -> a) -> List a -> a +foldl1 f zs + | null zs = errorEmptyList "foldl1" + | otherwise = go (head zs) (tail zs) + where + go !z xs + | null xs = z + | otherwise = go (f z (head xs)) (tail xs) +{-# INLINE foldl1 #-} + +-- | /O(n)/. 'foldr', applied to a binary operator, a starting value (typically +-- the right-identity of the operator), and a list, reduces the list +-- using the binary operator, from right to left: +-- +-- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...) +-- +foldr :: AdaptList a => (a -> b -> b) -> b -> List a -> b +foldr k z xs = go xs + where + go ys + | null xs = z + | otherwise = head ys `k` go (tail ys) +{-# INLINE foldr #-} + +-- | /O(n)/. 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty lists. +foldr1 :: AdaptList a => (a -> a -> a) -> List a -> a +foldr1 k xs + | null xs = errorEmptyList "foldr1" + | otherwise = go (head xs) (tail xs) + where + go z ys + | null ys = z + | otherwise = z `k` go (head ys) (tail ys) +{-# INLINE foldr1 #-} + +-- --------------------------------------------------------------------- +-- * Special folds + +-- | /O(n)/. Concatenate a list of lists. +-- concat :: [[a]] -> [a] +concat :: (AdaptList (List a), AdaptList a) + => List (List a) -> List a +concat xss0 = to xss0 + where + go xs xss + | null xs = to xss + | otherwise = head xs `cons` go (tail xs) xss + to xs + | null xs = empty + | otherwise = go (head xs) (tail xs) +{-# INLINE concat #-} + +-- | /O(n)/, /fusion/. Map a function over a list and concatenate the results. +concatMap :: (AdaptList a1, AdaptList a) + => (a -> List a1) -> List a -> List a1 +concatMap f = foldr (\x y -> f x ++ y) empty +{-# INLINE concatMap #-} + +-- | /O(n)/. 'and' returns the conjunction of a Boolean list. For the result to be +-- 'True', the list must be finite; 'False', however, results from a 'False' +-- value at a finite index of a finite or infinite list. +-- +and :: List Bool -> Bool +and xs + | null xs = True + | Prelude.not (head xs) = False + | otherwise = and (tail xs) +{-# INLINE and #-} + +-- | /O(n)/. 'or' returns the disjunction of a Boolean list. For the result to be +-- 'False', the list must be finite; 'True', however, results from a 'True' +-- value at a finite index of a finite or infinite list. +or :: List Bool -> Bool +or xs + | null xs = False + | head xs = True + | otherwise = or (tail xs) +{-# INLINE or #-} + +-- | /O(n)/. Applied to a predicate and a list, 'any' determines if any element +-- of the list satisfies the predicate. +any :: AdaptList a => (a -> Bool) -> List a -> Bool +any p xs0 = go xs0 + where + go xs + | null xs = False + | otherwise = case p (head xs) of + True -> True + _ -> go (tail xs) +{-# INLINE any #-} + +-- | Applied to a predicate and a list, 'all' determines if all elements +-- of the list satisfy the predicate. +all :: AdaptList a => (a -> Bool) -> List a -> Bool +all p xs0 = go xs0 + where + go xs + | null xs = True + | otherwise = case p (head xs) of + True -> go (tail xs) + _ -> False +{-# INLINE all #-} + +-- | /O(n)/, /fusion/. The 'sum' function computes the sum of a finite list of numbers. +sum :: (AdaptList a, Prelude.Num a) => List a -> a +sum l = go l 0 + where + go xs !a + | null xs = a + | otherwise = go (tail xs) (a Prelude.+ head xs) +{-# INLINE sum #-} + +-- | /O(n)/,/fusion/. The 'product' function computes the product of a finite list of numbers. +product :: (AdaptList a, Prelude.Num a) => List a -> a +product l = go l 1 + where + go xs !a + | null xs = a + | otherwise = go (tail xs) (a Prelude.* head xs) +{-# INLINE product #-} + +-- | /O(n)/. 'maximum' returns the maximum value from a list, +-- which must be non-empty, finite, and of an ordered type. +-- It is a special case of 'Data.List.maximumBy', which allows the +-- programmer to supply their own comparison function. +maximum :: (AdaptList a, Prelude.Ord a) => List a -> a +maximum xs + | null xs = errorEmptyList "maximum" + | otherwise = foldl1 Prelude.max xs +{-# INLINE maximum #-} + +-- | /O(n)/. 'minimum' returns the minimum value from a list, +-- which must be non-empty, finite, and of an ordered type. +-- It is a special case of 'Data.List.minimumBy', which allows the +-- programmer to supply their own comparison function. +minimum :: (AdaptList a, Prelude.Ord a) => List a -> a +minimum xs + | null xs = errorEmptyList "minimum" + | otherwise = foldl1 Prelude.min xs +{-# INLINE minimum #-} + +-- --------------------------------------------------------------------- +-- * Building lists +-- ** Scans + +-- | /O(n)/. 'scanl' is similar to 'foldl', but returns a list of successive +-- reduced values from the left: +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Properties: +-- +-- > last (scanl f z xs) == foldl f z x +-- +scanl :: (AdaptList b, AdaptList a) => (a -> b -> a) -> a -> List b -> List a +scanl f q ls = q `cons` if null ls + then empty + else scanl f (f q (head ls)) (tail ls) +{-# INLINE scanl #-} + +-- | /O(n)/. 'scanl1' is a variant of 'scanl' that has no starting value argument: +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +-- +scanl1 :: AdaptList a => (a -> a -> a) -> List a -> List a +scanl1 f xs + | null xs = empty + | otherwise = scanl f (head xs) (tail xs) +{-# INLINE scanl1 #-} + +-- | /O(n)/. 'scanr' is the right-to-left dual of 'scanl'. +-- Properties: +-- +-- > head (scanr f z xs) == foldr f z xs +-- +scanr :: (AdaptList a, AdaptList b) => (a -> b -> b) -> b -> List a -> List b +scanr f q0 xs + | null xs = cons q0 empty + | otherwise = f (head xs) (head qs) `cons` qs + where qs = scanr f q0 (tail xs) +{-# INLINE scanr #-} + +-- | 'scanr1' is a variant of 'scanr' that has no starting value argument. +scanr1 :: AdaptList a => (a -> a -> a) -> List a -> List a +scanr1 f xs + | null xs = empty + | null (tail xs) = xs + | otherwise = f (head xs) (head qs) `cons` qs + where qs = scanr1 f (tail xs) + +------------------------------------------------------------------------ +-- ** Infinite lists + +-- | /O(n)/, 'iterate' @f x@ returns an infinite list of repeated applications +-- of @f@ to @x@: +-- +-- > iterate f x == [x, f x, f (f x), ...] +iterate :: AdaptList a => (a -> a) -> a -> List a +iterate f x = go x + where go z = z `cons` go (f z) +{-# INLINE iterate #-} + +-- | /O(n)/. 'repeat' @x@ is an infinite list, with @x@ the value of every element. +repeat :: AdaptList a => a -> List a +repeat x = xs where xs = x `cons` xs +{-# INLINE repeat #-} + +-- | /O(n)/. 'replicate' @n x@ is a list of length @n@ with @x@ the value of +-- every element. +-- It is an instance of the more general 'Data.List.genericReplicate', +-- in which @n@ may be of any integral type. +-- +replicate :: AdaptList a => Int -> a -> List a +replicate n0 _ | n0 <= 0 = empty +replicate n0 x = go n0 + where + go 0 = empty + go n = x `cons` go (n-1) +{-# INLINE replicate #-} + +-- | /fusion/. 'cycle' ties a finite list into a circular one, or equivalently, +-- the infinite repetition of the original list. It is the identity +-- on infinite lists. +-- +cycle :: AdaptList a => List a -> List a +cycle xs0 + | null xs0 = errorEmptyList "cycle" + | otherwise = go xs0 + where + go xs + | null xs = go xs0 + | otherwise = head xs `cons` go (tail xs) +{-# INLINE cycle #-} + +-- --------------------------------------------------------------------- +-- ** Unfolding + +-- | The 'unfoldr' function is a \`dual\' to 'foldr': while 'foldr' +-- reduces a list to a summary value, 'unfoldr' builds a list from +-- a seed value. The function takes the element and returns 'Nothing' +-- if it is done producing the list or returns 'Just' @(a,b)@, in which +-- case, @a@ is a prepended to the list and @b@ is used as the next +-- element in a recursive call. For example, +-- +-- > iterate f == unfoldr (\x -> Just (x, f x)) +-- +-- In some cases, 'unfoldr' can undo a 'foldr' operation: +-- +-- > unfoldr f' (foldr f z xs) == xs +-- +-- if the following holds: +-- +-- > f' (f x y) = Just (x,y) +-- > f' z = Nothing +-- +-- A simple use of unfoldr: +-- +-- > unfoldr (\b -> if b == 0 then Nothing else Just (b, b-1)) 10 +-- > [10,9,8,7,6,5,4,3,2,1] +-- +-- /TODO/: AdaptPair state. +-- +unfoldr :: AdaptList a => (b -> Prelude.Maybe (a, b)) -> b -> List a +unfoldr f b0 = unfold b0 + where + unfold b = case f b of + Prelude.Just (a,b') -> a `cons` unfold b' + Prelude.Nothing -> empty +{-# INLINE unfoldr #-} + +------------------------------------------------------------------------ +-- * Sublists +-- ** Extracting sublists + +-- | /O(n)/. 'take' @n@, applied to a list @xs@, returns the prefix of @xs@ +-- of length @n@, or @xs@ itself if @n > 'length' xs@: +-- +-- > take 5 "Hello World!" == "Hello" +-- > take 3 [1,2,3,4,5] == [1,2,3] +-- > take 3 [1,2] == [1,2] +-- > take 3 [] == [] +-- > take (-1) [1,2] == [] +-- > take 0 [1,2] == [] +-- +-- It is an instance of the more general 'Data.List.genericTake', +-- in which @n@ may be of any integral type. +-- +take :: AdaptList a => Int -> List a -> List a +take i _ | i <= 0 = empty +take i ls = go i ls + where + go :: AdaptList a => Int -> List a -> List a + go 0 _ = empty + go n xs + | null xs = empty + | otherwise = (head xs) `cons` go (n-1) (tail xs) +{-# INLINE take #-} + +-- | /O(n)/. 'drop' @n xs@ returns the suffix of @xs@ +-- after the first @n@ elements, or @[]@ if @n > 'length' xs@: +-- +-- > drop 6 "Hello World!" == "World!" +-- > drop 3 [1,2,3,4,5] == [4,5] +-- > drop 3 [1,2] == [] +-- > drop 3 [] == [] +-- > drop (-1) [1,2] == [1,2] +-- > drop 0 [1,2] == [1,2] +-- +-- It is an instance of the more general 'Data.List.genericDrop', +-- in which @n@ may be of any integral type. +-- +drop :: AdaptList a => Int -> List a -> List a +drop n ls + | n Prelude.< 0 = ls + | otherwise = go n ls + where + go :: AdaptList a => Int -> List a -> List a + go 0 xs = xs + go m xs + | null xs = empty + | otherwise = go (m-1) (tail xs) +{-# INLINE drop #-} + +-- | 'splitAt' @n xs@ returns a tuple where first element is @xs@ prefix of +-- length @n@ and second element is the remainder of the list: +-- +-- > splitAt 6 "Hello World!" == ("Hello ","World!") +-- > splitAt 3 [1,2,3,4,5] == ([1,2,3],[4,5]) +-- > splitAt 1 [1,2,3] == ([1],[2,3]) +-- > splitAt 3 [1,2,3] == ([1,2,3],[]) +-- > splitAt 4 [1,2,3] == ([1,2,3],[]) +-- > splitAt 0 [1,2,3] == ([],[1,2,3]) +-- > splitAt (-1) [1,2,3] == ([],[1,2,3]) +-- +-- It is equivalent to @('take' n xs, 'drop' n xs)@. +-- 'splitAt' is an instance of the more general 'Data.List.genericSplitAt', +-- in which @n@ may be of any integral type. +-- +splitAt :: AdaptList a => Int -> List a -> (List a, List a) +splitAt n ls + | n Prelude.< 0 = (empty, ls) + | otherwise = go n ls + where + go :: AdaptList a => Int -> List a -> (List a, List a) + go 0 xs = (empty, xs) + go m xs + | null xs = (empty, empty) + | otherwise = (head xs `cons` xs', xs'') + where + (xs', xs'') = go (m-1) (tail xs) +{-# INLINE splitAt #-} + +-- --------------------------------------------------------------------- +-- * Searching lists +-- ** Searching by equality + +-- | /O(n)/. 'elem' is the list membership predicate, usually written +-- in infix form, e.g., @x `elem` xs@. +-- +elem :: (AdaptList a, Prelude.Eq a) => a -> List a -> Bool +elem x ys + | null ys = False + | x Prelude.== head ys = True + | otherwise = elem x (tail ys) +{-# INLINE elem #-} + +-- | /O(n)/. 'notElem' is the negation of 'elem'. +notElem :: (AdaptList a, Prelude.Eq a) => a -> List a -> Bool +notElem x xs = Prelude.not (elem x xs) +{-# INLINE notElem #-} + +-- | /O(n)/. 'filter', applied to a predicate and a list, returns the list of +-- those elements that satisfy the predicate; i.e., +-- +-- > filter p xs = [ x | x <- xs, p x] +-- +-- Properties: +-- +-- > filter p (filter q s) = filter (\x -> q x && p x) s +-- +filter :: AdaptList a => (a -> Bool) -> List a -> List a +filter p xs0 + | null xs0 = empty + | otherwise = go xs0 + where + go xs + | null xs = empty + | p x = x `cons` go ys + | otherwise = go ys + where x = head xs + ys = tail xs +{-# INLINE filter #-} + +------------------------------------------------------------------------ +-- * Zipping and unzipping lists + +-- | /O(n)/,/fusion/. 'zip' takes two lists and returns a list of +-- corresponding pairs. If one input list is short, excess elements of +-- the longer list are discarded. +-- +-- Properties: +-- +-- > zip a b = zipWith (,) a b +-- +zip :: (AdaptPair a b, AdaptList a , AdaptList b, AdaptList (Pair a b)) + => List a -> List b -> List (Pair a b) +zip as bs + | null as = empty + | null bs = empty + | otherwise = pair (head as) (head bs) `cons` zip (tail as) (tail bs) +{-# INLINE zip #-} + +------------------------------------------------------------------------ + +{- + + +-- ----------------------------------------------------------------------------- + +{- +-- --------------------------------------------------------------------- +-- ** Accumulating maps + +-- | The 'mapAccumL' function behaves like a combination of 'map' and +-- 'foldl'; it applies a function to each element of a list, passing +-- an accumulating parameter from left to right, and returning a final +-- value of this accumulator together with the new list. +-- +mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y]) +mapAccumL _ s [] = (s, []) +mapAccumL f s (x:xs) = (s'',y:ys) + where (s', y ) = f s x + (s'',ys) = mapAccumL f s' xs + +-- TODO fuse + +-- | The 'mapAccumR' function behaves like a combination of 'map' and +-- 'foldr'; it applies a function to each element of a list, passing +-- an accumulating parameter from right to left, and returning a final +-- value of this accumulator together with the new list. +-- +mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y]) +mapAccumR _ s [] = (s, []) +mapAccumR f s (x:xs) = (s'', y:ys) + where (s'',y ) = f s' x + (s', ys) = mapAccumR f s xs + +-- TODO fuse +-} + +-- | /O(n)/,/fusion/. 'takeWhile', applied to a predicate @p@ and a list @xs@, returns the +-- longest prefix (possibly empty) of @xs@ of elements that satisfy @p@: +-- +-- > takeWhile (< 3) [1,2,3,4,1,2,3,4] == [1,2] +-- > takeWhile (< 9) [1,2,3] == [1,2,3] +-- > takeWhile (< 0) [1,2,3] == [] +-- +takeWhile :: (a -> Bool) -> [a] -> [a] +takeWhile _ [] = [] +takeWhile p xs0 = go xs0 + where + go [] = [] + go (x:xs) + | p x = x : go xs + | otherwise = [] +{-# NOINLINE [1] takeWhile #-} + +{-# RULES +"takeWhile -> fusible" [~1] forall f xs. + takeWhile f xs = unstream (Stream.takeWhile f (stream xs)) +--"takeWhile -> unfused" [1] forall f xs. +-- unstream (Stream.takeWhile f (stream xs)) = takeWhile f xs + #-} + +-- | /O(n)/,/fusion/. 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@: +-- +-- > dropWhile (< 3) [1,2,3,4,5,1,2,3] == [3,4,5,1,2,3] +-- > dropWhile (< 9) [1,2,3] == [] +-- > dropWhile (< 0) [1,2,3] == [1,2,3] +-- +dropWhile :: (a -> Bool) -> [a] -> [a] +dropWhile _ [] = [] +dropWhile p xs0 = go xs0 + where + go [] = [] + go xs@(x:xs') + | p x = go xs' + | otherwise = xs +{-# NOINLINE [1] dropWhile #-} + +{-# RULES +"dropWhile -> fusible" [~1] forall f xs. + dropWhile f xs = unstream (Stream.dropWhile f (stream xs)) +--"dropWhile -> unfused" [1] forall f xs. +-- unstream (Stream.dropWhile f (stream xs)) = dropWhile f xs + #-} + +-- | 'span', applied to a predicate @p@ and a list @xs@, returns a tuple where +-- first element is longest prefix (possibly empty) of @xs@ of elements that +-- satisfy @p@ and second element is the remainder of the list: +-- +-- > span (< 3) [1,2,3,4,1,2,3,4] == ([1,2],[3,4,1,2,3,4]) +-- > span (< 9) [1,2,3] == ([1,2,3],[]) +-- > span (< 0) [1,2,3] == ([],[1,2,3]) +-- +-- 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ +span :: (a -> Bool) -> [a] -> ([a], [a]) +span _ [] = ([], []) +span p xs0 = go xs0 + where + go [] = ([], []) + go xs@(x:xs') + | p x = let (ys,zs) = go xs' + in (x:ys,zs) + | otherwise = ([],xs) + +-- TODO fuse +-- Hmm, these do a lot of sharing, but is it worth it? + +-- | 'break', applied to a predicate @p@ and a list @xs@, returns a tuple where +-- first element is longest prefix (possibly empty) of @xs@ of elements that +-- /do not satisfy/ @p@ and second element is the remainder of the list: +-- +-- > break (> 3) [1,2,3,4,1,2,3,4] == ([1,2,3],[4,1,2,3,4]) +-- > break (< 9) [1,2,3] == ([],[1,2,3]) +-- > break (> 9) [1,2,3] == ([1,2,3],[]) +-- +-- 'break' @p@ is equivalent to @'span' ('not' . p)@. +-- +break :: (a -> Bool) -> [a] -> ([a], [a]) +break _ [] = ([], []) +break p xs0 = go xs0 + where + go [] = ([], []) + go xs@(x:xs') + | p x = ([],xs) + | otherwise = let (ys,zs) = go xs' + in (x:ys,zs) + +-- TODO fuse + +-- | The 'group' function takes a list and returns a list of lists such +-- that the concatenation of the result is equal to the argument. Moreover, +-- each sublist in the result contains only equal elements. For example, +-- +-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] +-- +-- It is a special case of 'groupBy', which allows the programmer to supply +-- their own equality test. +group :: Eq a => [a] -> [[a]] +group [] = [] +group (x:xs) = (x:ys) : group zs + where (ys,zs) = span (x ==) xs + +-- TODO fuse + +-- | The 'inits' function returns all initial segments of the argument, +-- shortest first. For example, +-- +-- > inits "abc" == ["","a","ab","abc"] +-- +inits :: [a] -> [[a]] +inits [] = [] : [] +inits (x:xs) = [] : map (x:) (inits xs) + +-- TODO fuse + +-- | The 'tails' function returns all final segments of the argument, +-- longest first. For example, +-- +-- > tails "abc" == ["abc", "bc", "c",""] +-- +tails :: [a] -> [[a]] +tails [] = [] : [] +tails xxs@(_:xs) = xxs : tails xs + +-- TODO fuse + +------------------------------------------------------------------------ +-- * Predicates + +-- | /O(n)/,/fusion/. The 'isPrefixOf' function takes two lists and +-- returns 'True' iff the first list is a prefix of the second. +-- +isPrefixOf :: Eq a => [a] -> [a] -> Bool +isPrefixOf [] _ = True +isPrefixOf _ [] = False +isPrefixOf (x:xs) (y:ys) | x == y = isPrefixOf xs ys + | otherwise = False +{-# NOINLINE [1] isPrefixOf #-} + +{-# RULES +"isPrefixOf -> fusible" [~1] forall xs ys. + isPrefixOf xs ys = Stream.isPrefixOf (stream xs) (stream ys) +--"isPrefixOf -> unfused" [1] forall xs ys. +-- Stream.isPrefixOf (stream xs) (stream ys) = isPrefixOf xs ys + #-} + +-- | The 'isSuffixOf' function takes two lists and returns 'True' +-- iff the first list is a suffix of the second. +-- Both lists must be finite. +isSuffixOf :: Eq a => [a] -> [a] -> Bool +isSuffixOf x y = reverse x `isPrefixOf` reverse y + +-- TODO fuse + +-- | The 'isInfixOf' function takes two lists and returns 'True' +-- iff the first list is contained, wholly and intact, +-- anywhere within the second. +-- +-- Example: +-- +-- > isInfixOf "Haskell" "I really like Haskell." -> True +-- > isInfixOf "Ial" "I really like Haskell." -> False +-- +isInfixOf :: Eq a => [a] -> [a] -> Bool +isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) + +-- TODO fuse + +-- --------------------------------------------------------------------- + +-- | /O(n)/,/fusion/. 'lookup' @key assocs@ looks up a key in an association list. +lookup :: Eq a => a -> [(a, b)] -> Maybe b +lookup _ [] = Nothing +lookup key xys0 = go xys0 + where + go [] = Nothing + go ((x,y):xys) + | key == x = Just y + | otherwise = lookup key xys +{-# NOINLINE [1] lookup #-} + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +-- | /O(n)/,/fusion/. The 'find' function takes a predicate and a list and returns the +-- first element in the list matching the predicate, or 'Nothing' if +-- there is no such element. +find :: (a -> Bool) -> [a] -> Maybe a +find _ [] = Nothing +find p xs0 = go xs0 + where + go [] = Nothing + go (x:xs) | p x = Just x + | otherwise = go xs +{-# NOINLINE [1] find #-} + +{-# RULES +"find -> fusible" [~1] forall f xs. + find f xs = Stream.find f (stream xs) +--"find -> unfused" [1] forall f xs. +-- Stream.find f (stream xs) = find f xs + #-} + +-- | The 'partition' function takes a predicate a list and returns +-- the pair of lists of elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p xs == (filter p xs, filter (not . p) xs) +partition :: (a -> Bool) -> [a] -> ([a], [a]) +partition p xs = foldr (select p) ([],[]) xs +{-# INLINE partition #-} + +-- TODO fuse + +select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a]) +select p x ~(ts,fs) | p x = (x:ts,fs) + | otherwise = (ts, x:fs) + +------------------------------------------------------------------------ +-- * Indexing lists + +-- | /O(n)/,/fusion/. List index (subscript) operator, starting from 0. +-- It is an instance of the more general 'Data.List.genericIndex', +-- which takes an index of any integral type. +(!!) :: [a] -> Int -> a +xs0 !! n0 + | n0 < 0 = error "Prelude.(!!): negative index" + | otherwise = index xs0 n0 +#ifndef __HADDOCK__ + where + index [] _ = error "Prelude.(!!): index too large" + index (y:ys) n = if n == 0 then y else index ys (n-1) +#endif +{-# NOINLINE [1] (!!) #-} + +{-# RULES +"!! -> fusible" [~1] forall xs n. + xs !! n = Stream.index (stream xs) n +-- "!! -> unfused" [1] forall xs n. +-- Stream.index (stream xs) n = xs !! n + #-} + +-- | The 'elemIndex' function returns the index of the first element +-- in the given list which is equal (by '==') to the query element, +-- or 'Nothing' if there is no such element. +-- +-- Properties: +-- +-- > elemIndex x xs = listToMaybe [ n | (n,a) <- zip [0..] xs, a == x ] +-- > elemIndex x xs = findIndex (x==) xs +-- +elemIndex :: Eq a => a -> [a] -> Maybe Int +elemIndex x = findIndex (x==) +{-# INLINE elemIndex #-} +{- +elemIndex :: Eq a => a -> [a] -> Maybe Int +elemIndex y xs0 = loop_elemIndex xs0 0 +#ifndef __HADDOCK__ + where + loop_elemIndex [] !_ = Nothing + loop_elemIndex (x:xs) !n + | p x = Just n + | otherwise = loop_elemIndex xs (n + 1) + p = (y ==) +#endif +{-# NOINLINE [1] elemIndex #-} +-} +{- RULES +"elemIndex -> fusible" [~1] forall x xs. + elemIndex x xs = Stream.elemIndex x (stream xs) +"elemIndex -> unfused" [1] forall x xs. + Stream.elemIndex x (stream xs) = elemIndex x xs + -} + +-- | /O(n)/,/fusion/. The 'elemIndices' function extends 'elemIndex', by +-- returning the indices of all elements equal to the query element, in +-- ascending order. +-- +-- Properties: +-- +-- > length (filter (==a) xs) = length (elemIndices a xs) +-- +elemIndices :: Eq a => a -> [a] -> [Int] +elemIndices x = findIndices (x==) +{-# INLINE elemIndices #-} + +{- +elemIndices :: Eq a => a -> [a] -> [Int] +elemIndices y xs0 = loop_elemIndices xs0 0 +#ifndef __HADDOCK__ + where + loop_elemIndices [] !_ = [] + loop_elemIndices (x:xs) !n + | p x = n : loop_elemIndices xs (n + 1) + | otherwise = loop_elemIndices xs (n + 1) + p = (y ==) +#endif +{-# NOINLINE [1] elemIndices #-} +-} +{- RULES +"elemIndices -> fusible" [~1] forall x xs. + elemIndices x xs = unstream (Stream.elemIndices x (stream xs)) +"elemIndices -> unfused" [1] forall x xs. + unstream (Stream.elemIndices x (stream xs)) = elemIndices x xs + -} + +-- | The 'findIndex' function takes a predicate and a list and returns +-- the index of the first element in the list satisfying the predicate, +-- or 'Nothing' if there is no such element. +-- +-- Properties: +-- +-- > findIndex p xs = listToMaybe [ n | (n,x) <- zip [0..] xs, p x ] +-- +findIndex :: (a -> Bool) -> [a] -> Maybe Int +findIndex p ls = loop_findIndex ls 0# + where + loop_findIndex [] _ = Nothing + loop_findIndex (x:xs) n + | p x = Just (I# n) + | otherwise = loop_findIndex xs (n +# 1#) +{-# NOINLINE [1] findIndex #-} + +{-# RULES +"findIndex -> fusible" [~1] forall f xs. + findIndex f xs = Stream.findIndex f (stream xs) +-- "findIndex -> unfused" [1] forall f xs. +-- Stream.findIndex f (stream xs) = findIndex f xs + #-} + +-- | /O(n)/,/fusion/. The 'findIndices' function extends 'findIndex', by +-- returning the indices of all elements satisfying the predicate, in +-- ascending order. +-- +-- Properties: +-- +-- > length (filter p xs) = length (findIndices p xs) +-- +findIndices :: (a -> Bool) -> [a] -> [Int] +findIndices p ls = loop_findIndices ls 0# + where + loop_findIndices [] _ = [] + loop_findIndices (x:xs) n + | p x = I# n : loop_findIndices xs (n +# 1#) + | otherwise = loop_findIndices xs (n +# 1#) +{-# NOINLINE [1] findIndices #-} + +-- | /O(n)/,/fusion/. 'zip3' takes three lists and returns a list of +-- triples, analogous to 'zip'. +-- +-- Properties: +-- +-- > zip3 a b c = zipWith (,,) a b c +-- +zip3 :: [a] -> [b] -> [c] -> [(a, b, c)] +zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs +zip3 _ _ _ = [] +{-# NOINLINE [1] zip3 #-} + +{-# RULES +"zip3 -> fusible" [~1] forall xs ys zs. + zip3 xs ys zs = unstream (Stream.zipWith3 (,,) (stream xs) (stream ys) (stream zs)) +-- "zip3 -> unfused" [1] forall xs ys zs. +-- unstream (Stream.zipWith3 (,,) (stream xs) (stream ys) (stream zs)) = zip3 xs ys zs + #-} + +-- | /O(n)/,/fusion/. The 'zip4' function takes four lists and returns a list of +-- quadruples, analogous to 'zip'. +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)] +zip4 = zipWith4 (,,,) +{-# INLINE zip4 #-} + +-- | The 'zip5' function takes five lists and returns a list of +-- five-tuples, analogous to 'zip'. +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)] +zip5 = zipWith5 (,,,,) + +-- | The 'zip6' function takes six lists and returns a list of six-tuples, +-- analogous to 'zip'. +zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)] +zip6 = zipWith6 (,,,,,) + +-- | The 'zip7' function takes seven lists and returns a list of +-- seven-tuples, analogous to 'zip'. +zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a, b, c, d, e, f, g)] +zip7 = zipWith7 (,,,,,,) + +-- | /O(n)/,/fusion/. 'zipWith' generalises 'zip' by zipping with the +-- function given as the first argument, instead of a tupling function. +-- For example, @'zipWith' (+)@ is applied to two lists to produce the +-- list of corresponding sums. +-- Properties: +-- +-- > zipWith (,) = zip +-- +zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] +zipWith f (a:as) (b:bs) = f a b : zipWith f as bs +zipWith _ _ _ = [] +{-# INLINE [1] zipWith #-} + +--FIXME: If we change the above INLINE to NOINLINE then ghc goes into +-- a loop, why? Do we have some dodgy recursive rules somewhere? + +{-# RULES +"zipWith -> fusible" [~1] forall f xs ys. + zipWith f xs ys = unstream (Stream.zipWith f (stream xs) (stream ys)) +-- "zipWith -> unfused" [1] forall f xs ys. +-- unstream (Stream.zipWith f (stream xs) (stream ys)) = zipWith f xs ys + #-} + +-- | /O(n)/,/fusion/. The 'zipWith3' function takes a function which +-- combines three elements, as well as three lists and returns a list of +-- their point-wise combination, analogous to 'zipWith'. +-- +-- Properties: +-- +-- > zipWith3 (,,) = zip3 +-- +zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] +zipWith3 z (a:as) (b:bs) (c:cs) = z a b c : zipWith3 z as bs cs +zipWith3 _ _ _ _ = [] +{-# NOINLINE [1] zipWith3 #-} + +{-# RULES +"zipWith3 -> fusible" [~1] forall f xs ys zs. + zipWith3 f xs ys zs = unstream (Stream.zipWith3 f (stream xs) (stream ys) (stream zs)) +-- "zipWith3 -> unfused" [1] forall f xs ys zs. +-- unstream (Stream.zipWith3 f (stream xs) (stream ys) (stream zs)) = zipWith3 f xs ys zs + #-} + +-- | /O(n)/,/fusion/. The 'zipWith4' function takes a function which combines four +-- elements, as well as four lists and returns a list of their point-wise +-- combination, analogous to 'zipWith'. +zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] +zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4 z as bs cs ds +zipWith4 _ _ _ _ _ = [] +{-# NOINLINE [1] zipWith4 #-} + +{-# RULES +"zipWith4 -> fusible" [~1] forall f ws xs ys zs. + zipWith4 f ws xs ys zs = unstream (Stream.zipWith4 f (stream ws) (stream xs) (stream ys) (stream zs)) +-- "zipWith4 -> unfused" [1] forall f ws xs ys zs. +-- unstream (Stream.zipWith4 f (stream ws) (stream xs) (stream ys) (stream zs)) = zipWith4 f ws xs ys zs + #-} + +-- | The 'zipWith5' function takes a function which combines five +-- elements, as well as five lists and returns a list of their point-wise +-- combination, analogous to 'zipWith'. +zipWith5 :: (a -> b -> c -> d -> e -> f) + -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] +zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) + = z a b c d e : zipWith5 z as bs cs ds es +zipWith5 _ _ _ _ _ _ = [] + +-- TODO fuse + +-- | The 'zipWith6' function takes a function which combines six +-- elements, as well as six lists and returns a list of their point-wise +-- combination, analogous to 'zipWith'. +zipWith6 :: (a -> b -> c -> d -> e -> f -> g) + -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] +zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) + = z a b c d e f : zipWith6 z as bs cs ds es fs +zipWith6 _ _ _ _ _ _ _ = [] + +-- TODO fuse + +-- | The 'zipWith7' function takes a function which combines seven +-- elements, as well as seven lists and returns a list of their point-wise +-- combination, analogous to 'zipWith'. +zipWith7 :: (a -> b -> c -> d -> e -> f -> g -> h) + -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [h] +zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) + = z a b c d e f g : zipWith7 z as bs cs ds es fs gs +zipWith7 _ _ _ _ _ _ _ _ = [] + +-- TODO fuse + +------------------------------------------------------------------------ +-- unzips + +-- | 'unzip' transforms a list of pairs into a list of first components +-- and a list of second components. +unzip :: [(a, b)] -> ([a], [b]) +unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[]) + +-- TODO fuse + +-- | The 'unzip3' function takes a list of triples and returns three +-- lists, analogous to 'unzip'. +unzip3 :: [(a, b, c)] -> ([a], [b], [c]) +unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) ([],[],[]) + +-- TODO fuse + +-- | The 'unzip4' function takes a list of quadruples and returns four +-- lists, analogous to 'unzip'. +unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) +unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) -> + (a:as,b:bs,c:cs,d:ds)) + ([],[],[],[]) + +-- TODO fuse + +-- | The 'unzip5' function takes a list of five-tuples and returns five +-- lists, analogous to 'unzip'. +unzip5 :: [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e]) +unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) -> + (a:as,b:bs,c:cs,d:ds,e:es)) + ([],[],[],[],[]) + +-- TODO fuse + +-- | The 'unzip6' function takes a list of six-tuples and returns six +-- lists, analogous to 'unzip'. +unzip6 :: [(a, b, c, d, e, f)] -> ([a], [b], [c], [d], [e], [f]) +unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs)) + ([],[],[],[],[],[]) + +-- TODO fuse + +-- | The 'unzip7' function takes a list of seven-tuples and returns +-- seven lists, analogous to 'unzip'. +unzip7 :: [(a, b, c, d, e, f, g)] -> ([a], [b], [c], [d], [e], [f], [g]) +unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) + ([],[],[],[],[],[],[]) + +-- TODO fuse + +------------------------------------------------------------------------ +-- * Special lists +-- ** Functions on strings + +-- | /O(O)/,/fusion/. 'lines' breaks a string up into a list of strings +-- at newline characters. The resulting strings do not contain +-- newlines. +lines :: String -> [String] +lines [] = [] +lines s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines s'' +--TODO: can we do better than this and preserve the same strictness? + +{- +-- This implementation is fast but too strict :-( +-- it doesn't yield each line until it has seen the ending '\n' + +lines :: String -> [String] +lines [] = [] +lines cs0 = go [] cs0 + where + go l [] = reverse l : [] + go l ('\n':cs) = reverse l : case cs of + [] -> [] + _ -> go [] cs + go l ( c :cs) = go (c:l) cs +-} +{-# INLINE [1] lines #-} + +{- RULES +"lines -> fusible" [~1] forall xs. + lines xs = unstream (Stream.lines (stream xs)) +"lines -> unfused" [1] forall xs. + unstream (Stream.lines (stream xs)) = lines xs + -} + +-- | 'words' breaks a string up into a list of words, which were delimited +-- by white space. +words :: String -> [String] +words s = case dropWhile isSpace s of + "" -> [] + s' -> w : words s'' + where (w, s'') = break isSpace s' +-- TODO fuse +--TODO: can we do better than this and preserve the same strictness? + +{- +-- This implementation is fast but too strict :-( +-- it doesn't yield each word until it has seen the ending space + +words cs0 = dropSpaces cs0 + where + dropSpaces :: String -> [String] + dropSpaces [] = [] + dropSpaces (c:cs) + | isSpace c = dropSpaces cs + | otherwise = munchWord [c] cs + + munchWord :: String -> String -> [String] + munchWord w [] = reverse w : [] + munchWord w (c:cs) + | isSpace c = reverse w : dropSpaces cs + | otherwise = munchWord (c:w) cs +-} + +-- | /O(n)/,/fusion/. 'unlines' is an inverse operation to 'lines'. +-- It joins lines, after appending a terminating newline to each. +-- +-- > unlines xs = concatMap (++"\n") +-- +unlines :: [String] -> String +unlines css0 = to css0 + where go [] css = '\n' : to css + go (c:cs) css = c : go cs css + + to [] = [] + to (cs:css) = go cs css +{-# NOINLINE [1] unlines #-} + +-- +-- fuse via: +-- unlines xs = concatMap (snoc xs '\n') +-- +{- RULES +"unlines -> fusible" [~1] forall xs. + unlines xs = unstream (Stream.concatMap (\x -> Stream.snoc (stream x) '\n') (stream xs)) +"unlines -> unfused" [1] forall xs. + unstream (Stream.concatMap (\x -> Stream.snoc (stream x) '\n') (stream xs)) = unlines xs + -} + +-- | 'unwords' is an inverse operation to 'words'. +-- It joins words with separating spaces. +unwords :: [String] -> String +unwords [] = [] +unwords (cs0:css0) = go cs0 css0 + where go [] css = to css + go (c:cs) css = c : go cs css + + to [] = [] + to (cs:ccs) = ' ' : go cs ccs + +-- TODO fuse + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +-- | The 'nub' function removes duplicate elements from a list. +-- In particular, it keeps only the first occurrence of each element. +-- (The name 'nub' means \`essence\'.) +-- It is a special case of 'nubBy', which allows the programmer to supply +-- their own equality test. +-- +nub :: Eq a => [a] -> [a] +nub l = nub' l [] + where + nub' [] _ = [] + nub' (x:xs) ls + | x `elem` ls = nub' xs ls + | otherwise = x : nub' xs (x:ls) + +{- RULES +-- ndm's optimisation +"sort/nub" forall xs. sort (nub xs) = map head (group (sort xs)) + -} + +-- TODO fuse + +-- | 'delete' @x@ removes the first occurrence of @x@ from its list argument. +-- For example, +-- +-- > delete 'a' "banana" == "bnana" +-- +-- It is a special case of 'deleteBy', which allows the programmer to +-- supply their own equality test. +-- +delete :: Eq a => a -> [a] -> [a] +delete = deleteBy (==) + +-- TODO fuse + +-- | The '\\' function is list difference ((non-associative). +-- In the result of @xs@ '\\' @ys@, the first occurrence of each element of +-- @ys@ in turn (if any) has been removed from @xs@. Thus +-- +-- > (xs ++ ys) \\ xs == ys. +-- +-- It is a special case of 'deleteFirstsBy', which allows the programmer +-- to supply their own equality test. +(\\) :: Eq a => [a] -> [a] -> [a] +(\\) = foldl (flip delete) + +-- | The 'union' function returns the list union of the two lists. +-- For example, +-- +-- > "dog" `union` "cow" == "dogcw" +-- +-- Duplicates, and elements of the first list, are removed from the +-- the second list, but if the first list contains duplicates, so will +-- the result. +-- It is a special case of 'unionBy', which allows the programmer to supply +-- their own equality test. +-- +union :: Eq a => [a] -> [a] -> [a] +union = unionBy (==) + +-- TODO fuse + +-- | The 'intersect' function takes the list intersection of two lists. +-- For example, +-- +-- > [1,2,3,4] `intersect` [2,4,6,8] == [2,4] +-- +-- If the first list contains duplicates, so will the result. +-- It is a special case of 'intersectBy', which allows the programmer to +-- supply their own equality test. +-- +intersect :: Eq a => [a] -> [a] -> [a] +intersect = intersectBy (==) + +-- TODO fuse + +------------------------------------------------------------------------ +-- ** Ordered lists + +-- TODO stuff in Ord can use Map/IntMap +-- TODO Hooray, an Ord constraint! we could use a better structure. + +-- | The 'sort' function implements a stable sorting algorithm. +-- It is a special case of 'sortBy', which allows the programmer to supply +-- their own comparison function. +-- +-- Properties: +-- +-- > not (null x) ==> (head . sort) x = minimum x +-- > not (null x) ==> (last . sort) x = maximum x +-- +sort :: Ord a => [a] -> [a] +sort l = mergesort compare l + +-- TODO fuse, we have an Ord constraint! + +-- | /O(n)/,/fusion/. The 'insert' function takes an element and a list and inserts the +-- element into the list at the last position where it is still less +-- than or equal to the next element. In particular, if the list +-- is sorted before the call, the result will also be sorted. +-- It is a special case of 'insertBy', which allows the programmer to +-- supply their own comparison function. +-- +insert :: Ord a => a -> [a] -> [a] +insert e ls = insertBy (compare) e ls +{-# INLINE insert #-} + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +-- | The 'nubBy' function behaves just like 'nub', except it uses a +-- user-supplied equality predicate instead of the overloaded '==' +-- function. +nubBy :: (a -> a -> Bool) -> [a] -> [a] +nubBy eq l = nubBy' l [] + where + nubBy' [] _ = [] + nubBy' (y:ys) xs + | elem_by eq y xs = nubBy' ys xs + | otherwise = y : nubBy' ys (y:xs) + +-- TODO fuse + +-- Not exported: +-- Note that we keep the call to `eq` with arguments in the +-- same order as in the reference implementation +-- 'xs' is the list of things we've seen so far, +-- 'y' is the potential new element +-- +elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool +elem_by _ _ [] = False +elem_by eq y (x:xs) = if x `eq` y then True else elem_by eq y xs + +-- | The 'deleteBy' function behaves like 'delete', but takes a +-- user-supplied equality predicate. +deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] +deleteBy _ _ [] = [] +deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys + +-- TODO fuse + +deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +deleteFirstsBy eq = foldl (flip (deleteBy eq)) + + +-- | The 'unionBy' function is the non-overloaded version of 'union'. +unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs + +-- TODO fuse + +-- | The 'intersectBy' function is the non-overloaded version of 'intersect'. +intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] + +-- TODO fuse + +-- | The 'groupBy' function is the non-overloaded version of 'group'. +groupBy :: (a -> a -> Bool) -> [a] -> [[a]] +groupBy _ [] = [] +groupBy eq (x:xs) = (x:ys) : groupBy eq zs + where (ys,zs) = span (eq x) xs + +-- TODO fuse + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +-- | The 'sortBy' function is the non-overloaded version of 'sort'. +sortBy :: (a -> a -> Ordering) -> [a] -> [a] +sortBy cmp l = mergesort cmp l + +-- TODO fuse + +mergesort :: (a -> a -> Ordering) -> [a] -> [a] +mergesort cmp xs = mergesort' cmp (map wrap xs) + +mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a] +mergesort' _ [] = [] +mergesort' _ [xs] = xs +mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss) + +merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]] +merge_pairs _ [] = [] +merge_pairs _ [xs] = [xs] +merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss + +merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +merge _ xs [] = xs +merge _ [] ys = ys +merge cmp (x:xs) (y:ys) + = case x `cmp` y of + GT -> y : merge cmp (x:xs) ys + _ -> x : merge cmp xs (y:ys) + +wrap :: a -> [a] +wrap x = [x] + +-- | /O(n)/,/fusion/. The non-overloaded version of 'insert'. +insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a] +insertBy _ x [] = [x] +insertBy cmp x ys@(y:ys') + = case cmp x y of + GT -> y : insertBy cmp x ys' + _ -> x : ys +{-# NOINLINE [1] insertBy #-} + +{-# RULES +"insertBy -> fusible" [~1] forall f x xs. + insertBy f x xs = unstream (Stream.insertBy f x (stream xs)) +-- "insertBy -> unfused" [1] forall f x xs. +-- unstream (Stream.insertBy f x (stream xs)) = insertBy f x xs + #-} + +-- | /O(n)/,/fusion/. The 'maximumBy' function takes a comparison function and a list +-- and returns the greatest element of the list by the comparison function. +-- The list must be finite and non-empty. +-- +maximumBy :: (a -> a -> Ordering) -> [a] -> a +maximumBy _ [] = error "List.maximumBy: empty list" +maximumBy cmp xs = foldl1 max' xs + where + max' x y = case cmp x y of + GT -> x + _ -> y +{-# NOINLINE [1] maximumBy #-} + +{-# RULES +"maximumBy -> fused" [~1] forall p xs. + maximumBy p xs = Stream.maximumBy p (stream xs) +-- "maximumBy -> unfused" [1] forall p xs. +-- Stream.maximumBy p (stream xs) = maximumBy p xs + #-} + +-- | /O(n)/,/fusion/. The 'minimumBy' function takes a comparison function and a list +-- and returns the least element of the list by the comparison function. +-- The list must be finite and non-empty. +minimumBy :: (a -> a -> Ordering) -> [a] -> a +minimumBy _ [] = error "List.minimumBy: empty list" +minimumBy cmp xs = foldl1 min' xs + where + min' x y = case cmp x y of + GT -> y + _ -> x +{-# NOINLINE [1] minimumBy #-} + +{-# RULES +"minimumBy -> fused" [~1] forall p xs. + minimumBy p xs = Stream.minimumBy p (stream xs) +-- "minimumBy -> unfused" [1] forall p xs. +-- Stream.minimumBy p (stream xs) = minimumBy p xs + #-} + +------------------------------------------------------------------------ +-- * The \"generic\" operations + +-- | The 'genericLength' function is an overloaded version of 'length'. In +-- particular, instead of returning an 'Int', it returns any type which is +-- an instance of 'Num'. It is, however, less efficient than 'length'. +-- +genericLength :: Num i => [b] -> i +genericLength [] = 0 +genericLength (_:l) = 1 + genericLength l +{-# NOINLINE [1] genericLength #-} + +{-# RULES +"genericLength -> fusible" [~1] forall xs. + genericLength xs = Stream.genericLength (stream xs) +-- "genericLength -> unfused" [1] forall xs. +-- Stream.genericLength (stream xs) = genericLength xs + #-} + +{-# RULES +"genericLength -> length/Int" genericLength = length :: [a] -> Int + #-} + +-- | /O(n)/,/fusion/. The 'genericTake' function is an overloaded version of 'take', which +-- accepts any 'Integral' value as the number of elements to take. +genericTake :: Integral i => i -> [a] -> [a] +genericTake 0 _ = [] +genericTake _ [] = [] +genericTake n (x:xs) + | n > 0 = x : genericTake (n-1) xs + | otherwise = error "List.genericTake: negative argument" +{-# NOINLINE [1] genericTake #-} + +{-# RULES +"genericTake -> fusible" [~1] forall xs n. + genericTake n xs = unstream (Stream.genericTake n (stream xs)) +-- "genericTake -> unfused" [1] forall xs n. +-- unstream (Stream.genericTake n (stream xs)) = genericTake n xs + #-} + +{-# RULES +"genericTake -> take/Int" genericTake = take :: Int -> [a] -> [a] + #-} + +-- | /O(n)/,/fusion/. The 'genericDrop' function is an overloaded version of 'drop', which +-- accepts any 'Integral' value as the number of elements to drop. +genericDrop :: Integral i => i -> [a] -> [a] +genericDrop 0 xs = xs +genericDrop _ [] = [] +genericDrop n (_:xs) | n > 0 = genericDrop (n-1) xs +genericDrop _ _ = error "List.genericDrop: negative argument" +{-# NOINLINE [1] genericDrop #-} + +{-# RULES +"genericDrop -> fusible" [~1] forall xs n. + genericDrop n xs = unstream (Stream.genericDrop n (stream xs)) +-- "genericDrop -> unfused" [1] forall xs n. +-- unstream (Stream.genericDrop n (stream xs)) = genericDrop n xs + #-} + +{-# RULES +"genericDrop -> drop/Int" genericDrop = drop :: Int -> [a] -> [a] + #-} + +-- | /O(n)/,/fusion/. The 'genericIndex' function is an overloaded version of '!!', which +-- accepts any 'Integral' value as the index. +genericIndex :: Integral a => [b] -> a -> b +genericIndex (x:_) 0 = x +genericIndex (_:xs) n + | n > 0 = genericIndex xs (n-1) + | otherwise = error "List.genericIndex: negative argument." +genericIndex _ _ = error "List.genericIndex: index too large." +{-# NOINLINE [1] genericIndex #-} + + +-- can we pull the n > 0 test out and do it just once? +-- probably not since we don't know what n-1 does!! +-- can only specialise it for sane Integral instances :-( + +{-# RULES +"genericIndex -> fusible" [~1] forall xs n. + genericIndex xs n = Stream.genericIndex (stream xs) n +-- "genericIndex -> unfused" [1] forall xs n. +-- Stream.genericIndex (stream xs) n = genericIndex n xs + #-} + +{-# RULES +"genericIndex -> index/Int" genericIndex = (!!) :: [a] -> Int -> a + #-} + +-- | /O(n)/,/fusion/. The 'genericSplitAt' function is an overloaded +-- version of 'splitAt', which accepts any 'Integral' value as the +-- position at which to split. +-- +genericSplitAt :: Integral i => i -> [a] -> ([a], [a]) +genericSplitAt 0 xs = ([],xs) +genericSplitAt _ [] = ([],[]) +genericSplitAt n (x:xs) | n > 0 = (x:xs',xs'') + where (xs',xs'') = genericSplitAt (n-1) xs +genericSplitAt _ _ = error "List.genericSplitAt: negative argument" + +{-# RULES +"genericSplitAt -> fusible" [~1] forall xs n. + genericSplitAt n xs = Stream.genericSplitAt n (stream xs) +-- "genericSplitAt -> unfused" [1] forall xs n. +-- Stream.genericSplitAt n (stream xs) = genericSplitAt n xs + #-} + +{-# RULES +"genericSplitAt -> splitAt/Int" genericSplitAt = splitAt :: Int -> [a] -> ([a], [a]) + #-} + +-- | /O(n)/,/fusion/. The 'genericReplicate' function is an overloaded version of 'replicate', +-- which accepts any 'Integral' value as the number of repetitions to make. +-- +genericReplicate :: Integral i => i -> a -> [a] +genericReplicate n x = genericTake n (repeat x) +{-# INLINE genericReplicate #-} + +{-# RULES +"genericReplicate -> replicate/Int" genericReplicate = replicate :: Int -> a -> [a] + #-} +-} + +-- --------------------------------------------------------------------- +-- Internal utilities + +-- Common up near identical calls to `error' to reduce the number +-- constant strings created when compiled: +errorEmptyList :: Prelude.String -> a +errorEmptyList fun = moduleError fun "empty list" +{-# NOINLINE errorEmptyList #-} + +moduleError :: Prelude.String -> Prelude.String -> a +moduleError fun msg = Prelude.error ("Data.Adaptive.List." Prelude.++ fun Prelude.++ ':':' ':msg) +{-# NOINLINE moduleError #-} + +bottom :: a +bottom = Prelude.error "Data.List.Stream: bottom" +{-# NOINLINE bottom #-} + +------------------------------------------------------------------------ +-- Instances + +instance (AdaptList a, Prelude.Eq a) => Prelude.Eq (List a) where + xs == ys + | null xs Prelude.&& null ys = True + | null xs = False + | null ys = False + | otherwise = (head xs Prelude.== head ys) + Prelude.&& (tail xs Prelude.== tail ys) + +instance (AdaptList a, Prelude.Ord a) => Prelude.Ord (List a) where + compare xs ys + | null xs Prelude.&& null ys = EQ + | null xs = LT + | null ys = GT + | otherwise = case compare (head xs) (head ys) of + EQ -> compare (tail xs) (tail ys) + other -> other + +instance (AdaptList a, Prelude.Show a) => Prelude.Show (List a) where + showsPrec _ = Prelude.showList . toList + +------------------------------------------------------------------------ + +-- Generic adaptive pair: won't flatten! + +{- +Data/Adaptive/List.hs:1687:9: + Conflicting family instance declarations: + data instance List (Pair a b) + -- Defined at Data/Adaptive/List.hs:1687:9-12 + data instance List (Pair Int Int) + -- Defined at Data/Adaptive/List.hs:1699:9-12 +-} + +{- + -- looks illegal? +instance AdaptPair a b => AdaptList (Pair a b) where + data List (Pair a b) = EmptyPair | ConsPair {-# UNPACK #-}!(Pair a b) (List (Pair a b)) + empty = EmptyPair + cons x xs = ConsPair x xs + null EmptyPair = True + null _ = False + head EmptyPair = errorEmptyList "head" + head (ConsPair x _) = x + tail EmptyPair = errorEmptyList "tail" + tail (ConsPair _ xs) = xs +-} + +-- Monomorphic, but we have to flatten ourselves. GHC is doing something wrong. +instance AdaptList (Pair Int Int) where + data List (Pair Int Int) + = EmptyPairIntInt +-- | ConsPairIntInt {-# UNPACK #-}!(Pair Int Int) (List (Pair Int Int)) + -- this isn't unpacking + | ConsPairIntInt {-# UNPACK #-}!Int {-# UNPACK #-}!Int (List (Pair Int Int)) + + empty = EmptyPairIntInt + cons x xs = ConsPairIntInt (fst x) (snd x) xs + + null EmptyPairIntInt = True + null _ = False + + head EmptyPairIntInt = errorEmptyList "head" + head (ConsPairIntInt x y _) = pair x y + tail EmptyPairIntInt = errorEmptyList "tail" + tail (ConsPairIntInt _ _ xs) = xs + +------------------------------------------------------------------------ + +-- | We can unpack bools! +instance AdaptList Bool where + data List Bool = EmptyBool | ConsBool {-# UNPACK #-}!Int (List Bool) + + empty = EmptyBool + cons x xs = ConsBool (Prelude.fromEnum x) xs -- pack + null EmptyBool = True + null _ = False + + head EmptyBool = errorEmptyList "head" + head (ConsBool x _) = Prelude.toEnum x + + tail EmptyBool = errorEmptyList "tail" + tail (ConsBool _ xs) = xs + +------------------------------------------------------------------------ +-- Generated by scripts/derive-list.hs + +instance AdaptList Int where + data List Int = EmptyInt | ConsInt {-# UNPACK #-}!Int (List Int) + empty = EmptyInt + cons = ConsInt + null EmptyInt = True + null _ = False + head EmptyInt = errorEmptyList "head" + head (ConsInt x _) = x + tail EmptyInt = errorEmptyList "tail" + tail (ConsInt _ x) = x + +instance AdaptList Integer where + data List Integer = EmptyInteger | ConsInteger {-# UNPACK #-}!Integer (List Integer) + empty = EmptyInteger + cons = ConsInteger + null EmptyInteger = True + null _ = False + head EmptyInteger = errorEmptyList "head" + head (ConsInteger x _) = x + tail EmptyInteger = errorEmptyList "tail" + tail (ConsInteger _ x) = x + +instance AdaptList Int8 where + data List Int8 = EmptyInt8 | ConsInt8 {-# UNPACK #-}!Int8 (List Int8) + empty = EmptyInt8 + cons = ConsInt8 + null EmptyInt8 = True + null _ = False + head EmptyInt8 = errorEmptyList "head" + head (ConsInt8 x _) = x + tail EmptyInt8 = errorEmptyList "tail" + tail (ConsInt8 _ x) = x + +instance AdaptList Int16 where + data List Int16 = EmptyInt16 | ConsInt16 {-# UNPACK #-}!Int16 (List Int16) + empty = EmptyInt16 + cons = ConsInt16 + null EmptyInt16 = True + null _ = False + head EmptyInt16 = errorEmptyList "head" + head (ConsInt16 x _) = x + tail EmptyInt16 = errorEmptyList "tail" + tail (ConsInt16 _ x) = x + +instance AdaptList Int32 where + data List Int32 = EmptyInt32 | ConsInt32 {-# UNPACK #-}!Int32 (List Int32) + empty = EmptyInt32 + cons = ConsInt32 + null EmptyInt32 = True + null _ = False + head EmptyInt32 = errorEmptyList "head" + head (ConsInt32 x _) = x + tail EmptyInt32 = errorEmptyList "tail" + tail (ConsInt32 _ x) = x + +instance AdaptList Int64 where + data List Int64 = EmptyInt64 | ConsInt64 {-# UNPACK #-}!Int64 (List Int64) + empty = EmptyInt64 + cons = ConsInt64 + null EmptyInt64 = True + null _ = False + head EmptyInt64 = errorEmptyList "head" + head (ConsInt64 x _) = x + tail EmptyInt64 = errorEmptyList "tail" + tail (ConsInt64 _ x) = x + +instance AdaptList Word where + data List Word = EmptyWord | ConsWord {-# UNPACK #-}!Word (List Word) + empty = EmptyWord + cons = ConsWord + null EmptyWord = True + null _ = False + head EmptyWord = errorEmptyList "head" + head (ConsWord x _) = x + tail EmptyWord = errorEmptyList "tail" + tail (ConsWord _ x) = x + +instance AdaptList Word8 where + data List Word8 = EmptyWord8 | ConsWord8 {-# UNPACK #-}!Word8 (List Word8) + empty = EmptyWord8 + cons = ConsWord8 + null EmptyWord8 = True + null _ = False + head EmptyWord8 = errorEmptyList "head" + head (ConsWord8 x _) = x + tail EmptyWord8 = errorEmptyList "tail" + tail (ConsWord8 _ x) = x + +instance AdaptList Word16 where + data List Word16 = EmptyWord16 | ConsWord16 {-# UNPACK #-}!Word16 (List Word16) + empty = EmptyWord16 + cons = ConsWord16 + null EmptyWord16 = True + null _ = False + head EmptyWord16 = errorEmptyList "head" + head (ConsWord16 x _) = x + tail EmptyWord16 = errorEmptyList "tail" + tail (ConsWord16 _ x) = x + +instance AdaptList Word32 where + data List Word32 = EmptyWord32 | ConsWord32 {-# UNPACK #-}!Word32 (List Word32) + empty = EmptyWord32 + cons = ConsWord32 + null EmptyWord32 = True + null _ = False + head EmptyWord32 = errorEmptyList "head" + head (ConsWord32 x _) = x + tail EmptyWord32 = errorEmptyList "tail" + tail (ConsWord32 _ x) = x + +instance AdaptList Word64 where + data List Word64 = EmptyWord64 | ConsWord64 {-# UNPACK #-}!Word64 (List Word64) + empty = EmptyWord64 + cons = ConsWord64 + null EmptyWord64 = True + null _ = False + head EmptyWord64 = errorEmptyList "head" + head (ConsWord64 x _) = x + tail EmptyWord64 = errorEmptyList "tail" + tail (ConsWord64 _ x) = x + +instance AdaptList Double where + data List Double = EmptyDouble | ConsDouble {-# UNPACK #-}!Double (List Double) + empty = EmptyDouble + cons = ConsDouble + null EmptyDouble = True + null _ = False + head EmptyDouble = errorEmptyList "head" + head (ConsDouble x _) = x + tail EmptyDouble = errorEmptyList "tail" + tail (ConsDouble _ x) = x + +instance AdaptList Float where + data List Float = EmptyFloat | ConsFloat {-# UNPACK #-}!Float (List Float) + empty = EmptyFloat + cons = ConsFloat + null EmptyFloat = True + null _ = False + head EmptyFloat = errorEmptyList "head" + head (ConsFloat x _) = x + tail EmptyFloat = errorEmptyList "tail" + tail (ConsFloat _ x) = x + +instance AdaptList Char where + data List Char = EmptyChar | ConsChar {-# UNPACK #-}!Char (List Char) + empty = EmptyChar + cons = ConsChar + null EmptyChar = True + null _ = False + head EmptyChar = errorEmptyList "head" + head (ConsChar x _) = x + tail EmptyChar = errorEmptyList "tail" + tail (ConsChar _ x) = x diff --git a/Data/Adaptive/Tuple.hs b/Data/Adaptive/Tuple.hs --- a/Data/Adaptive/Tuple.hs +++ b/Data/Adaptive/Tuple.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, OverlappingInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} -- | -- Module : Data.Adaptive.Tuple @@ -62,7 +64,7 @@ -- -- | Representation-improving polymorphic tuples. -- -class Adapt a b where +class AdaptPair a b where data Pair a b @@ -78,43 +80,43 @@ ------------------------------------------------------------------------ -- | Construct a new pair. -pair :: Adapt a b => a -> b -> Pair a b +pair :: AdaptPair a b => a -> b -> Pair a b pair = curry id -- | 'uncurry' converts a curried function to a function on pairs. -uncurry :: Adapt a b => (a -> b -> c) -> (Pair a b -> c) +uncurry :: AdaptPair a b => (a -> b -> c) -> (Pair a b -> c) uncurry f p = f (fst p) (snd p) -- | Convert an adaptive pair to a regular polymorphic tuple -fromPair :: Adapt a b => Pair a b -> (a, b) +fromPair :: AdaptPair a b => Pair a b -> (a, b) fromPair = uncurry (,) -- | Convert a regular polymorphic tuple to an adaptive pair -toPair :: Adapt a b => (a,b) -> Pair a b +toPair :: AdaptPair a b => (a,b) -> Pair a b toPair (a,b) = pair a b ------------------------------------------------------------------------ -- Methods -- standalone deriving crashes here: do not attempt it. --- deriving instance (Eq a, Eq b, Adapt a b) => Eq (Pair a b) --- deriving instance (Ord a, Ord b, Adapt a b) => Ord (Pair a b) --- deriving instance (Show a, Show b, Adapt a b) => Show (Pair a b) +-- deriving instance (Eq a, Eq b, AdaptPair a b) => Eq (Pair a b) +-- deriving instance (Ord a, Ord b, AdaptPair a b) => Ord (Pair a b) +-- deriving instance (Show a, Show b, AdaptPair a b) => Show (Pair a b) -instance (Bounded a, Bounded b, Adapt a b) => Bounded (Pair a b) where +instance (Bounded a, Bounded b, AdaptPair a b) => Bounded (Pair a b) where minBound = pair minBound minBound maxBound = pair maxBound maxBound -instance (Eq a, Eq b, Adapt a b) => Eq (Pair a b) where +instance (Eq a, Eq b, AdaptPair a b) => Eq (Pair a b) where p == q = fst p == fst q && snd p == snd q -instance (Ord a, Ord b, Adapt a b) => Ord (Pair a b) where +instance (Ord a, Ord b, AdaptPair a b) => Ord (Pair a b) where compare p q = compare (fst p) (fst q) `compare` compare (snd p) (snd q) -instance (Show a, Show b, Adapt a b) => Show (Pair a b) where +instance (Show a, Show b, AdaptPair a b) => Show (Pair a b) where show p = "Pair " ++ show (fst p) ++ " "++ show (snd p) ------------------------------------------------------------------------ @@ -123,7 +125,7 @@ -- -instance Adapt a b where +instance AdaptPair a b where newtype Pair a b = PairPair { unPair :: (,) a b } fst = Prelude.fst . unPair @@ -135,1192 +137,1199 @@ -- Hand written instances: -- -instance Adapt () () where +instance AdaptPair () () where data Pair () () = PUnit fst PUnit = () snd PUnit = () curry f _ _ = f PUnit +instance AdaptPair Bool Bool where + data Pair Bool Bool = PBool {-# UNPACK #-}!Int {-# UNPACK #-}!Int + + fst (PBool x _) = Prelude.toEnum x + snd (PBool _ x) = Prelude.toEnum x + curry f x y = f (PBool (Prelude.fromEnum x) (Prelude.fromEnum y)) + -- TODO: sums: Bool -- TODO: products: pairs ------------------------------------------------------------------------ -- --- Generated by scripts/derive.hs +-- Generated by scripts/derive-pair.hs -- -instance Adapt Int Int where +instance AdaptPair Int Int where data Pair Int Int = PairIntInt {-# UNPACK #-}!Int {-# UNPACK #-}!Int fst (PairIntInt a _) = a snd (PairIntInt _ b) = b curry f x y = f (PairIntInt x y) -instance Adapt Int Integer where +instance AdaptPair Int Integer where data Pair Int Integer = PairIntInteger {-# UNPACK #-}!Int {-# UNPACK #-}!Integer fst (PairIntInteger a _) = a snd (PairIntInteger _ b) = b curry f x y = f (PairIntInteger x y) -instance Adapt Int Int8 where +instance AdaptPair Int Int8 where data Pair Int Int8 = PairIntInt8 {-# UNPACK #-}!Int {-# UNPACK #-}!Int8 fst (PairIntInt8 a _) = a snd (PairIntInt8 _ b) = b curry f x y = f (PairIntInt8 x y) -instance Adapt Int Int16 where +instance AdaptPair Int Int16 where data Pair Int Int16 = PairIntInt16 {-# UNPACK #-}!Int {-# UNPACK #-}!Int16 fst (PairIntInt16 a _) = a snd (PairIntInt16 _ b) = b curry f x y = f (PairIntInt16 x y) -instance Adapt Int Int32 where +instance AdaptPair Int Int32 where data Pair Int Int32 = PairIntInt32 {-# UNPACK #-}!Int {-# UNPACK #-}!Int32 fst (PairIntInt32 a _) = a snd (PairIntInt32 _ b) = b curry f x y = f (PairIntInt32 x y) -instance Adapt Int Int64 where +instance AdaptPair Int Int64 where data Pair Int Int64 = PairIntInt64 {-# UNPACK #-}!Int {-# UNPACK #-}!Int64 fst (PairIntInt64 a _) = a snd (PairIntInt64 _ b) = b curry f x y = f (PairIntInt64 x y) -instance Adapt Int Word where +instance AdaptPair Int Word where data Pair Int Word = PairIntWord {-# UNPACK #-}!Int {-# UNPACK #-}!Word fst (PairIntWord a _) = a snd (PairIntWord _ b) = b curry f x y = f (PairIntWord x y) -instance Adapt Int Word8 where +instance AdaptPair Int Word8 where data Pair Int Word8 = PairIntWord8 {-# UNPACK #-}!Int {-# UNPACK #-}!Word8 fst (PairIntWord8 a _) = a snd (PairIntWord8 _ b) = b curry f x y = f (PairIntWord8 x y) -instance Adapt Int Word16 where +instance AdaptPair Int Word16 where data Pair Int Word16 = PairIntWord16 {-# UNPACK #-}!Int {-# UNPACK #-}!Word16 fst (PairIntWord16 a _) = a snd (PairIntWord16 _ b) = b curry f x y = f (PairIntWord16 x y) -instance Adapt Int Word32 where +instance AdaptPair Int Word32 where data Pair Int Word32 = PairIntWord32 {-# UNPACK #-}!Int {-# UNPACK #-}!Word32 fst (PairIntWord32 a _) = a snd (PairIntWord32 _ b) = b curry f x y = f (PairIntWord32 x y) -instance Adapt Int Word64 where +instance AdaptPair Int Word64 where data Pair Int Word64 = PairIntWord64 {-# UNPACK #-}!Int {-# UNPACK #-}!Word64 fst (PairIntWord64 a _) = a snd (PairIntWord64 _ b) = b curry f x y = f (PairIntWord64 x y) -instance Adapt Int Double where +instance AdaptPair Int Double where data Pair Int Double = PairIntDouble {-# UNPACK #-}!Int {-# UNPACK #-}!Double fst (PairIntDouble a _) = a snd (PairIntDouble _ b) = b curry f x y = f (PairIntDouble x y) -instance Adapt Int Float where +instance AdaptPair Int Float where data Pair Int Float = PairIntFloat {-# UNPACK #-}!Int {-# UNPACK #-}!Float fst (PairIntFloat a _) = a snd (PairIntFloat _ b) = b curry f x y = f (PairIntFloat x y) -instance Adapt Int Char where +instance AdaptPair Int Char where data Pair Int Char = PairIntChar {-# UNPACK #-}!Int {-# UNPACK #-}!Char fst (PairIntChar a _) = a snd (PairIntChar _ b) = b curry f x y = f (PairIntChar x y) -instance Adapt Integer Int where +instance AdaptPair Integer Int where data Pair Integer Int = PairIntegerInt {-# UNPACK #-}!Integer {-# UNPACK #-}!Int fst (PairIntegerInt a _) = a snd (PairIntegerInt _ b) = b curry f x y = f (PairIntegerInt x y) -instance Adapt Integer Integer where +instance AdaptPair Integer Integer where data Pair Integer Integer = PairIntegerInteger {-# UNPACK #-}!Integer {-# UNPACK #-}!Integer fst (PairIntegerInteger a _) = a snd (PairIntegerInteger _ b) = b curry f x y = f (PairIntegerInteger x y) -instance Adapt Integer Int8 where +instance AdaptPair Integer Int8 where data Pair Integer Int8 = PairIntegerInt8 {-# UNPACK #-}!Integer {-# UNPACK #-}!Int8 fst (PairIntegerInt8 a _) = a snd (PairIntegerInt8 _ b) = b curry f x y = f (PairIntegerInt8 x y) -instance Adapt Integer Int16 where +instance AdaptPair Integer Int16 where data Pair Integer Int16 = PairIntegerInt16 {-# UNPACK #-}!Integer {-# UNPACK #-}!Int16 fst (PairIntegerInt16 a _) = a snd (PairIntegerInt16 _ b) = b curry f x y = f (PairIntegerInt16 x y) -instance Adapt Integer Int32 where +instance AdaptPair Integer Int32 where data Pair Integer Int32 = PairIntegerInt32 {-# UNPACK #-}!Integer {-# UNPACK #-}!Int32 fst (PairIntegerInt32 a _) = a snd (PairIntegerInt32 _ b) = b curry f x y = f (PairIntegerInt32 x y) -instance Adapt Integer Int64 where +instance AdaptPair Integer Int64 where data Pair Integer Int64 = PairIntegerInt64 {-# UNPACK #-}!Integer {-# UNPACK #-}!Int64 fst (PairIntegerInt64 a _) = a snd (PairIntegerInt64 _ b) = b curry f x y = f (PairIntegerInt64 x y) -instance Adapt Integer Word where +instance AdaptPair Integer Word where data Pair Integer Word = PairIntegerWord {-# UNPACK #-}!Integer {-# UNPACK #-}!Word fst (PairIntegerWord a _) = a snd (PairIntegerWord _ b) = b curry f x y = f (PairIntegerWord x y) -instance Adapt Integer Word8 where +instance AdaptPair Integer Word8 where data Pair Integer Word8 = PairIntegerWord8 {-# UNPACK #-}!Integer {-# UNPACK #-}!Word8 fst (PairIntegerWord8 a _) = a snd (PairIntegerWord8 _ b) = b curry f x y = f (PairIntegerWord8 x y) -instance Adapt Integer Word16 where +instance AdaptPair Integer Word16 where data Pair Integer Word16 = PairIntegerWord16 {-# UNPACK #-}!Integer {-# UNPACK #-}!Word16 fst (PairIntegerWord16 a _) = a snd (PairIntegerWord16 _ b) = b curry f x y = f (PairIntegerWord16 x y) -instance Adapt Integer Word32 where +instance AdaptPair Integer Word32 where data Pair Integer Word32 = PairIntegerWord32 {-# UNPACK #-}!Integer {-# UNPACK #-}!Word32 fst (PairIntegerWord32 a _) = a snd (PairIntegerWord32 _ b) = b curry f x y = f (PairIntegerWord32 x y) -instance Adapt Integer Word64 where +instance AdaptPair Integer Word64 where data Pair Integer Word64 = PairIntegerWord64 {-# UNPACK #-}!Integer {-# UNPACK #-}!Word64 fst (PairIntegerWord64 a _) = a snd (PairIntegerWord64 _ b) = b curry f x y = f (PairIntegerWord64 x y) -instance Adapt Integer Double where +instance AdaptPair Integer Double where data Pair Integer Double = PairIntegerDouble {-# UNPACK #-}!Integer {-# UNPACK #-}!Double fst (PairIntegerDouble a _) = a snd (PairIntegerDouble _ b) = b curry f x y = f (PairIntegerDouble x y) -instance Adapt Integer Float where +instance AdaptPair Integer Float where data Pair Integer Float = PairIntegerFloat {-# UNPACK #-}!Integer {-# UNPACK #-}!Float fst (PairIntegerFloat a _) = a snd (PairIntegerFloat _ b) = b curry f x y = f (PairIntegerFloat x y) -instance Adapt Integer Char where +instance AdaptPair Integer Char where data Pair Integer Char = PairIntegerChar {-# UNPACK #-}!Integer {-# UNPACK #-}!Char fst (PairIntegerChar a _) = a snd (PairIntegerChar _ b) = b curry f x y = f (PairIntegerChar x y) -instance Adapt Int8 Int where +instance AdaptPair Int8 Int where data Pair Int8 Int = PairInt8Int {-# UNPACK #-}!Int8 {-# UNPACK #-}!Int fst (PairInt8Int a _) = a snd (PairInt8Int _ b) = b curry f x y = f (PairInt8Int x y) -instance Adapt Int8 Integer where +instance AdaptPair Int8 Integer where data Pair Int8 Integer = PairInt8Integer {-# UNPACK #-}!Int8 {-# UNPACK #-}!Integer fst (PairInt8Integer a _) = a snd (PairInt8Integer _ b) = b curry f x y = f (PairInt8Integer x y) -instance Adapt Int8 Int8 where +instance AdaptPair Int8 Int8 where data Pair Int8 Int8 = PairInt8Int8 {-# UNPACK #-}!Int8 {-# UNPACK #-}!Int8 fst (PairInt8Int8 a _) = a snd (PairInt8Int8 _ b) = b curry f x y = f (PairInt8Int8 x y) -instance Adapt Int8 Int16 where +instance AdaptPair Int8 Int16 where data Pair Int8 Int16 = PairInt8Int16 {-# UNPACK #-}!Int8 {-# UNPACK #-}!Int16 fst (PairInt8Int16 a _) = a snd (PairInt8Int16 _ b) = b curry f x y = f (PairInt8Int16 x y) -instance Adapt Int8 Int32 where +instance AdaptPair Int8 Int32 where data Pair Int8 Int32 = PairInt8Int32 {-# UNPACK #-}!Int8 {-# UNPACK #-}!Int32 fst (PairInt8Int32 a _) = a snd (PairInt8Int32 _ b) = b curry f x y = f (PairInt8Int32 x y) -instance Adapt Int8 Int64 where +instance AdaptPair Int8 Int64 where data Pair Int8 Int64 = PairInt8Int64 {-# UNPACK #-}!Int8 {-# UNPACK #-}!Int64 fst (PairInt8Int64 a _) = a snd (PairInt8Int64 _ b) = b curry f x y = f (PairInt8Int64 x y) -instance Adapt Int8 Word where +instance AdaptPair Int8 Word where data Pair Int8 Word = PairInt8Word {-# UNPACK #-}!Int8 {-# UNPACK #-}!Word fst (PairInt8Word a _) = a snd (PairInt8Word _ b) = b curry f x y = f (PairInt8Word x y) -instance Adapt Int8 Word8 where +instance AdaptPair Int8 Word8 where data Pair Int8 Word8 = PairInt8Word8 {-# UNPACK #-}!Int8 {-# UNPACK #-}!Word8 fst (PairInt8Word8 a _) = a snd (PairInt8Word8 _ b) = b curry f x y = f (PairInt8Word8 x y) -instance Adapt Int8 Word16 where +instance AdaptPair Int8 Word16 where data Pair Int8 Word16 = PairInt8Word16 {-# UNPACK #-}!Int8 {-# UNPACK #-}!Word16 fst (PairInt8Word16 a _) = a snd (PairInt8Word16 _ b) = b curry f x y = f (PairInt8Word16 x y) -instance Adapt Int8 Word32 where +instance AdaptPair Int8 Word32 where data Pair Int8 Word32 = PairInt8Word32 {-# UNPACK #-}!Int8 {-# UNPACK #-}!Word32 fst (PairInt8Word32 a _) = a snd (PairInt8Word32 _ b) = b curry f x y = f (PairInt8Word32 x y) -instance Adapt Int8 Word64 where +instance AdaptPair Int8 Word64 where data Pair Int8 Word64 = PairInt8Word64 {-# UNPACK #-}!Int8 {-# UNPACK #-}!Word64 fst (PairInt8Word64 a _) = a snd (PairInt8Word64 _ b) = b curry f x y = f (PairInt8Word64 x y) -instance Adapt Int8 Double where +instance AdaptPair Int8 Double where data Pair Int8 Double = PairInt8Double {-# UNPACK #-}!Int8 {-# UNPACK #-}!Double fst (PairInt8Double a _) = a snd (PairInt8Double _ b) = b curry f x y = f (PairInt8Double x y) -instance Adapt Int8 Float where +instance AdaptPair Int8 Float where data Pair Int8 Float = PairInt8Float {-# UNPACK #-}!Int8 {-# UNPACK #-}!Float fst (PairInt8Float a _) = a snd (PairInt8Float _ b) = b curry f x y = f (PairInt8Float x y) -instance Adapt Int8 Char where +instance AdaptPair Int8 Char where data Pair Int8 Char = PairInt8Char {-# UNPACK #-}!Int8 {-# UNPACK #-}!Char fst (PairInt8Char a _) = a snd (PairInt8Char _ b) = b curry f x y = f (PairInt8Char x y) -instance Adapt Int16 Int where +instance AdaptPair Int16 Int where data Pair Int16 Int = PairInt16Int {-# UNPACK #-}!Int16 {-# UNPACK #-}!Int fst (PairInt16Int a _) = a snd (PairInt16Int _ b) = b curry f x y = f (PairInt16Int x y) -instance Adapt Int16 Integer where +instance AdaptPair Int16 Integer where data Pair Int16 Integer = PairInt16Integer {-# UNPACK #-}!Int16 {-# UNPACK #-}!Integer fst (PairInt16Integer a _) = a snd (PairInt16Integer _ b) = b curry f x y = f (PairInt16Integer x y) -instance Adapt Int16 Int8 where +instance AdaptPair Int16 Int8 where data Pair Int16 Int8 = PairInt16Int8 {-# UNPACK #-}!Int16 {-# UNPACK #-}!Int8 fst (PairInt16Int8 a _) = a snd (PairInt16Int8 _ b) = b curry f x y = f (PairInt16Int8 x y) -instance Adapt Int16 Int16 where +instance AdaptPair Int16 Int16 where data Pair Int16 Int16 = PairInt16Int16 {-# UNPACK #-}!Int16 {-# UNPACK #-}!Int16 fst (PairInt16Int16 a _) = a snd (PairInt16Int16 _ b) = b curry f x y = f (PairInt16Int16 x y) -instance Adapt Int16 Int32 where +instance AdaptPair Int16 Int32 where data Pair Int16 Int32 = PairInt16Int32 {-# UNPACK #-}!Int16 {-# UNPACK #-}!Int32 fst (PairInt16Int32 a _) = a snd (PairInt16Int32 _ b) = b curry f x y = f (PairInt16Int32 x y) -instance Adapt Int16 Int64 where +instance AdaptPair Int16 Int64 where data Pair Int16 Int64 = PairInt16Int64 {-# UNPACK #-}!Int16 {-# UNPACK #-}!Int64 fst (PairInt16Int64 a _) = a snd (PairInt16Int64 _ b) = b curry f x y = f (PairInt16Int64 x y) -instance Adapt Int16 Word where +instance AdaptPair Int16 Word where data Pair Int16 Word = PairInt16Word {-# UNPACK #-}!Int16 {-# UNPACK #-}!Word fst (PairInt16Word a _) = a snd (PairInt16Word _ b) = b curry f x y = f (PairInt16Word x y) -instance Adapt Int16 Word8 where +instance AdaptPair Int16 Word8 where data Pair Int16 Word8 = PairInt16Word8 {-# UNPACK #-}!Int16 {-# UNPACK #-}!Word8 fst (PairInt16Word8 a _) = a snd (PairInt16Word8 _ b) = b curry f x y = f (PairInt16Word8 x y) -instance Adapt Int16 Word16 where +instance AdaptPair Int16 Word16 where data Pair Int16 Word16 = PairInt16Word16 {-# UNPACK #-}!Int16 {-# UNPACK #-}!Word16 fst (PairInt16Word16 a _) = a snd (PairInt16Word16 _ b) = b curry f x y = f (PairInt16Word16 x y) -instance Adapt Int16 Word32 where +instance AdaptPair Int16 Word32 where data Pair Int16 Word32 = PairInt16Word32 {-# UNPACK #-}!Int16 {-# UNPACK #-}!Word32 fst (PairInt16Word32 a _) = a snd (PairInt16Word32 _ b) = b curry f x y = f (PairInt16Word32 x y) -instance Adapt Int16 Word64 where +instance AdaptPair Int16 Word64 where data Pair Int16 Word64 = PairInt16Word64 {-# UNPACK #-}!Int16 {-# UNPACK #-}!Word64 fst (PairInt16Word64 a _) = a snd (PairInt16Word64 _ b) = b curry f x y = f (PairInt16Word64 x y) -instance Adapt Int16 Double where +instance AdaptPair Int16 Double where data Pair Int16 Double = PairInt16Double {-# UNPACK #-}!Int16 {-# UNPACK #-}!Double fst (PairInt16Double a _) = a snd (PairInt16Double _ b) = b curry f x y = f (PairInt16Double x y) -instance Adapt Int16 Float where +instance AdaptPair Int16 Float where data Pair Int16 Float = PairInt16Float {-# UNPACK #-}!Int16 {-# UNPACK #-}!Float fst (PairInt16Float a _) = a snd (PairInt16Float _ b) = b curry f x y = f (PairInt16Float x y) -instance Adapt Int16 Char where +instance AdaptPair Int16 Char where data Pair Int16 Char = PairInt16Char {-# UNPACK #-}!Int16 {-# UNPACK #-}!Char fst (PairInt16Char a _) = a snd (PairInt16Char _ b) = b curry f x y = f (PairInt16Char x y) -instance Adapt Int32 Int where +instance AdaptPair Int32 Int where data Pair Int32 Int = PairInt32Int {-# UNPACK #-}!Int32 {-# UNPACK #-}!Int fst (PairInt32Int a _) = a snd (PairInt32Int _ b) = b curry f x y = f (PairInt32Int x y) -instance Adapt Int32 Integer where +instance AdaptPair Int32 Integer where data Pair Int32 Integer = PairInt32Integer {-# UNPACK #-}!Int32 {-# UNPACK #-}!Integer fst (PairInt32Integer a _) = a snd (PairInt32Integer _ b) = b curry f x y = f (PairInt32Integer x y) -instance Adapt Int32 Int8 where +instance AdaptPair Int32 Int8 where data Pair Int32 Int8 = PairInt32Int8 {-# UNPACK #-}!Int32 {-# UNPACK #-}!Int8 fst (PairInt32Int8 a _) = a snd (PairInt32Int8 _ b) = b curry f x y = f (PairInt32Int8 x y) -instance Adapt Int32 Int16 where +instance AdaptPair Int32 Int16 where data Pair Int32 Int16 = PairInt32Int16 {-# UNPACK #-}!Int32 {-# UNPACK #-}!Int16 fst (PairInt32Int16 a _) = a snd (PairInt32Int16 _ b) = b curry f x y = f (PairInt32Int16 x y) -instance Adapt Int32 Int32 where +instance AdaptPair Int32 Int32 where data Pair Int32 Int32 = PairInt32Int32 {-# UNPACK #-}!Int32 {-# UNPACK #-}!Int32 fst (PairInt32Int32 a _) = a snd (PairInt32Int32 _ b) = b curry f x y = f (PairInt32Int32 x y) -instance Adapt Int32 Int64 where +instance AdaptPair Int32 Int64 where data Pair Int32 Int64 = PairInt32Int64 {-# UNPACK #-}!Int32 {-# UNPACK #-}!Int64 fst (PairInt32Int64 a _) = a snd (PairInt32Int64 _ b) = b curry f x y = f (PairInt32Int64 x y) -instance Adapt Int32 Word where +instance AdaptPair Int32 Word where data Pair Int32 Word = PairInt32Word {-# UNPACK #-}!Int32 {-# UNPACK #-}!Word fst (PairInt32Word a _) = a snd (PairInt32Word _ b) = b curry f x y = f (PairInt32Word x y) -instance Adapt Int32 Word8 where +instance AdaptPair Int32 Word8 where data Pair Int32 Word8 = PairInt32Word8 {-# UNPACK #-}!Int32 {-# UNPACK #-}!Word8 fst (PairInt32Word8 a _) = a snd (PairInt32Word8 _ b) = b curry f x y = f (PairInt32Word8 x y) -instance Adapt Int32 Word16 where +instance AdaptPair Int32 Word16 where data Pair Int32 Word16 = PairInt32Word16 {-# UNPACK #-}!Int32 {-# UNPACK #-}!Word16 fst (PairInt32Word16 a _) = a snd (PairInt32Word16 _ b) = b curry f x y = f (PairInt32Word16 x y) -instance Adapt Int32 Word32 where +instance AdaptPair Int32 Word32 where data Pair Int32 Word32 = PairInt32Word32 {-# UNPACK #-}!Int32 {-# UNPACK #-}!Word32 fst (PairInt32Word32 a _) = a snd (PairInt32Word32 _ b) = b curry f x y = f (PairInt32Word32 x y) -instance Adapt Int32 Word64 where +instance AdaptPair Int32 Word64 where data Pair Int32 Word64 = PairInt32Word64 {-# UNPACK #-}!Int32 {-# UNPACK #-}!Word64 fst (PairInt32Word64 a _) = a snd (PairInt32Word64 _ b) = b curry f x y = f (PairInt32Word64 x y) -instance Adapt Int32 Double where +instance AdaptPair Int32 Double where data Pair Int32 Double = PairInt32Double {-# UNPACK #-}!Int32 {-# UNPACK #-}!Double fst (PairInt32Double a _) = a snd (PairInt32Double _ b) = b curry f x y = f (PairInt32Double x y) -instance Adapt Int32 Float where +instance AdaptPair Int32 Float where data Pair Int32 Float = PairInt32Float {-# UNPACK #-}!Int32 {-# UNPACK #-}!Float fst (PairInt32Float a _) = a snd (PairInt32Float _ b) = b curry f x y = f (PairInt32Float x y) -instance Adapt Int32 Char where +instance AdaptPair Int32 Char where data Pair Int32 Char = PairInt32Char {-# UNPACK #-}!Int32 {-# UNPACK #-}!Char fst (PairInt32Char a _) = a snd (PairInt32Char _ b) = b curry f x y = f (PairInt32Char x y) -instance Adapt Int64 Int where +instance AdaptPair Int64 Int where data Pair Int64 Int = PairInt64Int {-# UNPACK #-}!Int64 {-# UNPACK #-}!Int fst (PairInt64Int a _) = a snd (PairInt64Int _ b) = b curry f x y = f (PairInt64Int x y) -instance Adapt Int64 Integer where +instance AdaptPair Int64 Integer where data Pair Int64 Integer = PairInt64Integer {-# UNPACK #-}!Int64 {-# UNPACK #-}!Integer fst (PairInt64Integer a _) = a snd (PairInt64Integer _ b) = b curry f x y = f (PairInt64Integer x y) -instance Adapt Int64 Int8 where +instance AdaptPair Int64 Int8 where data Pair Int64 Int8 = PairInt64Int8 {-# UNPACK #-}!Int64 {-# UNPACK #-}!Int8 fst (PairInt64Int8 a _) = a snd (PairInt64Int8 _ b) = b curry f x y = f (PairInt64Int8 x y) -instance Adapt Int64 Int16 where +instance AdaptPair Int64 Int16 where data Pair Int64 Int16 = PairInt64Int16 {-# UNPACK #-}!Int64 {-# UNPACK #-}!Int16 fst (PairInt64Int16 a _) = a snd (PairInt64Int16 _ b) = b curry f x y = f (PairInt64Int16 x y) -instance Adapt Int64 Int32 where +instance AdaptPair Int64 Int32 where data Pair Int64 Int32 = PairInt64Int32 {-# UNPACK #-}!Int64 {-# UNPACK #-}!Int32 fst (PairInt64Int32 a _) = a snd (PairInt64Int32 _ b) = b curry f x y = f (PairInt64Int32 x y) -instance Adapt Int64 Int64 where +instance AdaptPair Int64 Int64 where data Pair Int64 Int64 = PairInt64Int64 {-# UNPACK #-}!Int64 {-# UNPACK #-}!Int64 fst (PairInt64Int64 a _) = a snd (PairInt64Int64 _ b) = b curry f x y = f (PairInt64Int64 x y) -instance Adapt Int64 Word where +instance AdaptPair Int64 Word where data Pair Int64 Word = PairInt64Word {-# UNPACK #-}!Int64 {-# UNPACK #-}!Word fst (PairInt64Word a _) = a snd (PairInt64Word _ b) = b curry f x y = f (PairInt64Word x y) -instance Adapt Int64 Word8 where +instance AdaptPair Int64 Word8 where data Pair Int64 Word8 = PairInt64Word8 {-# UNPACK #-}!Int64 {-# UNPACK #-}!Word8 fst (PairInt64Word8 a _) = a snd (PairInt64Word8 _ b) = b curry f x y = f (PairInt64Word8 x y) -instance Adapt Int64 Word16 where +instance AdaptPair Int64 Word16 where data Pair Int64 Word16 = PairInt64Word16 {-# UNPACK #-}!Int64 {-# UNPACK #-}!Word16 fst (PairInt64Word16 a _) = a snd (PairInt64Word16 _ b) = b curry f x y = f (PairInt64Word16 x y) -instance Adapt Int64 Word32 where +instance AdaptPair Int64 Word32 where data Pair Int64 Word32 = PairInt64Word32 {-# UNPACK #-}!Int64 {-# UNPACK #-}!Word32 fst (PairInt64Word32 a _) = a snd (PairInt64Word32 _ b) = b curry f x y = f (PairInt64Word32 x y) -instance Adapt Int64 Word64 where +instance AdaptPair Int64 Word64 where data Pair Int64 Word64 = PairInt64Word64 {-# UNPACK #-}!Int64 {-# UNPACK #-}!Word64 fst (PairInt64Word64 a _) = a snd (PairInt64Word64 _ b) = b curry f x y = f (PairInt64Word64 x y) -instance Adapt Int64 Double where +instance AdaptPair Int64 Double where data Pair Int64 Double = PairInt64Double {-# UNPACK #-}!Int64 {-# UNPACK #-}!Double fst (PairInt64Double a _) = a snd (PairInt64Double _ b) = b curry f x y = f (PairInt64Double x y) -instance Adapt Int64 Float where +instance AdaptPair Int64 Float where data Pair Int64 Float = PairInt64Float {-# UNPACK #-}!Int64 {-# UNPACK #-}!Float fst (PairInt64Float a _) = a snd (PairInt64Float _ b) = b curry f x y = f (PairInt64Float x y) -instance Adapt Int64 Char where +instance AdaptPair Int64 Char where data Pair Int64 Char = PairInt64Char {-# UNPACK #-}!Int64 {-# UNPACK #-}!Char fst (PairInt64Char a _) = a snd (PairInt64Char _ b) = b curry f x y = f (PairInt64Char x y) -instance Adapt Word Int where +instance AdaptPair Word Int where data Pair Word Int = PairWordInt {-# UNPACK #-}!Word {-# UNPACK #-}!Int fst (PairWordInt a _) = a snd (PairWordInt _ b) = b curry f x y = f (PairWordInt x y) -instance Adapt Word Integer where +instance AdaptPair Word Integer where data Pair Word Integer = PairWordInteger {-# UNPACK #-}!Word {-# UNPACK #-}!Integer fst (PairWordInteger a _) = a snd (PairWordInteger _ b) = b curry f x y = f (PairWordInteger x y) -instance Adapt Word Int8 where +instance AdaptPair Word Int8 where data Pair Word Int8 = PairWordInt8 {-# UNPACK #-}!Word {-# UNPACK #-}!Int8 fst (PairWordInt8 a _) = a snd (PairWordInt8 _ b) = b curry f x y = f (PairWordInt8 x y) -instance Adapt Word Int16 where +instance AdaptPair Word Int16 where data Pair Word Int16 = PairWordInt16 {-# UNPACK #-}!Word {-# UNPACK #-}!Int16 fst (PairWordInt16 a _) = a snd (PairWordInt16 _ b) = b curry f x y = f (PairWordInt16 x y) -instance Adapt Word Int32 where +instance AdaptPair Word Int32 where data Pair Word Int32 = PairWordInt32 {-# UNPACK #-}!Word {-# UNPACK #-}!Int32 fst (PairWordInt32 a _) = a snd (PairWordInt32 _ b) = b curry f x y = f (PairWordInt32 x y) -instance Adapt Word Int64 where +instance AdaptPair Word Int64 where data Pair Word Int64 = PairWordInt64 {-# UNPACK #-}!Word {-# UNPACK #-}!Int64 fst (PairWordInt64 a _) = a snd (PairWordInt64 _ b) = b curry f x y = f (PairWordInt64 x y) -instance Adapt Word Word where +instance AdaptPair Word Word where data Pair Word Word = PairWordWord {-# UNPACK #-}!Word {-# UNPACK #-}!Word fst (PairWordWord a _) = a snd (PairWordWord _ b) = b curry f x y = f (PairWordWord x y) -instance Adapt Word Word8 where +instance AdaptPair Word Word8 where data Pair Word Word8 = PairWordWord8 {-# UNPACK #-}!Word {-# UNPACK #-}!Word8 fst (PairWordWord8 a _) = a snd (PairWordWord8 _ b) = b curry f x y = f (PairWordWord8 x y) -instance Adapt Word Word16 where +instance AdaptPair Word Word16 where data Pair Word Word16 = PairWordWord16 {-# UNPACK #-}!Word {-# UNPACK #-}!Word16 fst (PairWordWord16 a _) = a snd (PairWordWord16 _ b) = b curry f x y = f (PairWordWord16 x y) -instance Adapt Word Word32 where +instance AdaptPair Word Word32 where data Pair Word Word32 = PairWordWord32 {-# UNPACK #-}!Word {-# UNPACK #-}!Word32 fst (PairWordWord32 a _) = a snd (PairWordWord32 _ b) = b curry f x y = f (PairWordWord32 x y) -instance Adapt Word Word64 where +instance AdaptPair Word Word64 where data Pair Word Word64 = PairWordWord64 {-# UNPACK #-}!Word {-# UNPACK #-}!Word64 fst (PairWordWord64 a _) = a snd (PairWordWord64 _ b) = b curry f x y = f (PairWordWord64 x y) -instance Adapt Word Double where +instance AdaptPair Word Double where data Pair Word Double = PairWordDouble {-# UNPACK #-}!Word {-# UNPACK #-}!Double fst (PairWordDouble a _) = a snd (PairWordDouble _ b) = b curry f x y = f (PairWordDouble x y) -instance Adapt Word Float where +instance AdaptPair Word Float where data Pair Word Float = PairWordFloat {-# UNPACK #-}!Word {-# UNPACK #-}!Float fst (PairWordFloat a _) = a snd (PairWordFloat _ b) = b curry f x y = f (PairWordFloat x y) -instance Adapt Word Char where +instance AdaptPair Word Char where data Pair Word Char = PairWordChar {-# UNPACK #-}!Word {-# UNPACK #-}!Char fst (PairWordChar a _) = a snd (PairWordChar _ b) = b curry f x y = f (PairWordChar x y) -instance Adapt Word8 Int where +instance AdaptPair Word8 Int where data Pair Word8 Int = PairWord8Int {-# UNPACK #-}!Word8 {-# UNPACK #-}!Int fst (PairWord8Int a _) = a snd (PairWord8Int _ b) = b curry f x y = f (PairWord8Int x y) -instance Adapt Word8 Integer where +instance AdaptPair Word8 Integer where data Pair Word8 Integer = PairWord8Integer {-# UNPACK #-}!Word8 {-# UNPACK #-}!Integer fst (PairWord8Integer a _) = a snd (PairWord8Integer _ b) = b curry f x y = f (PairWord8Integer x y) -instance Adapt Word8 Int8 where +instance AdaptPair Word8 Int8 where data Pair Word8 Int8 = PairWord8Int8 {-# UNPACK #-}!Word8 {-# UNPACK #-}!Int8 fst (PairWord8Int8 a _) = a snd (PairWord8Int8 _ b) = b curry f x y = f (PairWord8Int8 x y) -instance Adapt Word8 Int16 where +instance AdaptPair Word8 Int16 where data Pair Word8 Int16 = PairWord8Int16 {-# UNPACK #-}!Word8 {-# UNPACK #-}!Int16 fst (PairWord8Int16 a _) = a snd (PairWord8Int16 _ b) = b curry f x y = f (PairWord8Int16 x y) -instance Adapt Word8 Int32 where +instance AdaptPair Word8 Int32 where data Pair Word8 Int32 = PairWord8Int32 {-# UNPACK #-}!Word8 {-# UNPACK #-}!Int32 fst (PairWord8Int32 a _) = a snd (PairWord8Int32 _ b) = b curry f x y = f (PairWord8Int32 x y) -instance Adapt Word8 Int64 where +instance AdaptPair Word8 Int64 where data Pair Word8 Int64 = PairWord8Int64 {-# UNPACK #-}!Word8 {-# UNPACK #-}!Int64 fst (PairWord8Int64 a _) = a snd (PairWord8Int64 _ b) = b curry f x y = f (PairWord8Int64 x y) -instance Adapt Word8 Word where +instance AdaptPair Word8 Word where data Pair Word8 Word = PairWord8Word {-# UNPACK #-}!Word8 {-# UNPACK #-}!Word fst (PairWord8Word a _) = a snd (PairWord8Word _ b) = b curry f x y = f (PairWord8Word x y) -instance Adapt Word8 Word8 where +instance AdaptPair Word8 Word8 where data Pair Word8 Word8 = PairWord8Word8 {-# UNPACK #-}!Word8 {-# UNPACK #-}!Word8 fst (PairWord8Word8 a _) = a snd (PairWord8Word8 _ b) = b curry f x y = f (PairWord8Word8 x y) -instance Adapt Word8 Word16 where +instance AdaptPair Word8 Word16 where data Pair Word8 Word16 = PairWord8Word16 {-# UNPACK #-}!Word8 {-# UNPACK #-}!Word16 fst (PairWord8Word16 a _) = a snd (PairWord8Word16 _ b) = b curry f x y = f (PairWord8Word16 x y) -instance Adapt Word8 Word32 where +instance AdaptPair Word8 Word32 where data Pair Word8 Word32 = PairWord8Word32 {-# UNPACK #-}!Word8 {-# UNPACK #-}!Word32 fst (PairWord8Word32 a _) = a snd (PairWord8Word32 _ b) = b curry f x y = f (PairWord8Word32 x y) -instance Adapt Word8 Word64 where +instance AdaptPair Word8 Word64 where data Pair Word8 Word64 = PairWord8Word64 {-# UNPACK #-}!Word8 {-# UNPACK #-}!Word64 fst (PairWord8Word64 a _) = a snd (PairWord8Word64 _ b) = b curry f x y = f (PairWord8Word64 x y) -instance Adapt Word8 Double where +instance AdaptPair Word8 Double where data Pair Word8 Double = PairWord8Double {-# UNPACK #-}!Word8 {-# UNPACK #-}!Double fst (PairWord8Double a _) = a snd (PairWord8Double _ b) = b curry f x y = f (PairWord8Double x y) -instance Adapt Word8 Float where +instance AdaptPair Word8 Float where data Pair Word8 Float = PairWord8Float {-# UNPACK #-}!Word8 {-# UNPACK #-}!Float fst (PairWord8Float a _) = a snd (PairWord8Float _ b) = b curry f x y = f (PairWord8Float x y) -instance Adapt Word8 Char where +instance AdaptPair Word8 Char where data Pair Word8 Char = PairWord8Char {-# UNPACK #-}!Word8 {-# UNPACK #-}!Char fst (PairWord8Char a _) = a snd (PairWord8Char _ b) = b curry f x y = f (PairWord8Char x y) -instance Adapt Word16 Int where +instance AdaptPair Word16 Int where data Pair Word16 Int = PairWord16Int {-# UNPACK #-}!Word16 {-# UNPACK #-}!Int fst (PairWord16Int a _) = a snd (PairWord16Int _ b) = b curry f x y = f (PairWord16Int x y) -instance Adapt Word16 Integer where +instance AdaptPair Word16 Integer where data Pair Word16 Integer = PairWord16Integer {-# UNPACK #-}!Word16 {-# UNPACK #-}!Integer fst (PairWord16Integer a _) = a snd (PairWord16Integer _ b) = b curry f x y = f (PairWord16Integer x y) -instance Adapt Word16 Int8 where +instance AdaptPair Word16 Int8 where data Pair Word16 Int8 = PairWord16Int8 {-# UNPACK #-}!Word16 {-# UNPACK #-}!Int8 fst (PairWord16Int8 a _) = a snd (PairWord16Int8 _ b) = b curry f x y = f (PairWord16Int8 x y) -instance Adapt Word16 Int16 where +instance AdaptPair Word16 Int16 where data Pair Word16 Int16 = PairWord16Int16 {-# UNPACK #-}!Word16 {-# UNPACK #-}!Int16 fst (PairWord16Int16 a _) = a snd (PairWord16Int16 _ b) = b curry f x y = f (PairWord16Int16 x y) -instance Adapt Word16 Int32 where +instance AdaptPair Word16 Int32 where data Pair Word16 Int32 = PairWord16Int32 {-# UNPACK #-}!Word16 {-# UNPACK #-}!Int32 fst (PairWord16Int32 a _) = a snd (PairWord16Int32 _ b) = b curry f x y = f (PairWord16Int32 x y) -instance Adapt Word16 Int64 where +instance AdaptPair Word16 Int64 where data Pair Word16 Int64 = PairWord16Int64 {-# UNPACK #-}!Word16 {-# UNPACK #-}!Int64 fst (PairWord16Int64 a _) = a snd (PairWord16Int64 _ b) = b curry f x y = f (PairWord16Int64 x y) -instance Adapt Word16 Word where +instance AdaptPair Word16 Word where data Pair Word16 Word = PairWord16Word {-# UNPACK #-}!Word16 {-# UNPACK #-}!Word fst (PairWord16Word a _) = a snd (PairWord16Word _ b) = b curry f x y = f (PairWord16Word x y) -instance Adapt Word16 Word8 where +instance AdaptPair Word16 Word8 where data Pair Word16 Word8 = PairWord16Word8 {-# UNPACK #-}!Word16 {-# UNPACK #-}!Word8 fst (PairWord16Word8 a _) = a snd (PairWord16Word8 _ b) = b curry f x y = f (PairWord16Word8 x y) -instance Adapt Word16 Word16 where +instance AdaptPair Word16 Word16 where data Pair Word16 Word16 = PairWord16Word16 {-# UNPACK #-}!Word16 {-# UNPACK #-}!Word16 fst (PairWord16Word16 a _) = a snd (PairWord16Word16 _ b) = b curry f x y = f (PairWord16Word16 x y) -instance Adapt Word16 Word32 where +instance AdaptPair Word16 Word32 where data Pair Word16 Word32 = PairWord16Word32 {-# UNPACK #-}!Word16 {-# UNPACK #-}!Word32 fst (PairWord16Word32 a _) = a snd (PairWord16Word32 _ b) = b curry f x y = f (PairWord16Word32 x y) -instance Adapt Word16 Word64 where +instance AdaptPair Word16 Word64 where data Pair Word16 Word64 = PairWord16Word64 {-# UNPACK #-}!Word16 {-# UNPACK #-}!Word64 fst (PairWord16Word64 a _) = a snd (PairWord16Word64 _ b) = b curry f x y = f (PairWord16Word64 x y) -instance Adapt Word16 Double where +instance AdaptPair Word16 Double where data Pair Word16 Double = PairWord16Double {-# UNPACK #-}!Word16 {-# UNPACK #-}!Double fst (PairWord16Double a _) = a snd (PairWord16Double _ b) = b curry f x y = f (PairWord16Double x y) -instance Adapt Word16 Float where +instance AdaptPair Word16 Float where data Pair Word16 Float = PairWord16Float {-# UNPACK #-}!Word16 {-# UNPACK #-}!Float fst (PairWord16Float a _) = a snd (PairWord16Float _ b) = b curry f x y = f (PairWord16Float x y) -instance Adapt Word16 Char where +instance AdaptPair Word16 Char where data Pair Word16 Char = PairWord16Char {-# UNPACK #-}!Word16 {-# UNPACK #-}!Char fst (PairWord16Char a _) = a snd (PairWord16Char _ b) = b curry f x y = f (PairWord16Char x y) -instance Adapt Word32 Int where +instance AdaptPair Word32 Int where data Pair Word32 Int = PairWord32Int {-# UNPACK #-}!Word32 {-# UNPACK #-}!Int fst (PairWord32Int a _) = a snd (PairWord32Int _ b) = b curry f x y = f (PairWord32Int x y) -instance Adapt Word32 Integer where +instance AdaptPair Word32 Integer where data Pair Word32 Integer = PairWord32Integer {-# UNPACK #-}!Word32 {-# UNPACK #-}!Integer fst (PairWord32Integer a _) = a snd (PairWord32Integer _ b) = b curry f x y = f (PairWord32Integer x y) -instance Adapt Word32 Int8 where +instance AdaptPair Word32 Int8 where data Pair Word32 Int8 = PairWord32Int8 {-# UNPACK #-}!Word32 {-# UNPACK #-}!Int8 fst (PairWord32Int8 a _) = a snd (PairWord32Int8 _ b) = b curry f x y = f (PairWord32Int8 x y) -instance Adapt Word32 Int16 where +instance AdaptPair Word32 Int16 where data Pair Word32 Int16 = PairWord32Int16 {-# UNPACK #-}!Word32 {-# UNPACK #-}!Int16 fst (PairWord32Int16 a _) = a snd (PairWord32Int16 _ b) = b curry f x y = f (PairWord32Int16 x y) -instance Adapt Word32 Int32 where +instance AdaptPair Word32 Int32 where data Pair Word32 Int32 = PairWord32Int32 {-# UNPACK #-}!Word32 {-# UNPACK #-}!Int32 fst (PairWord32Int32 a _) = a snd (PairWord32Int32 _ b) = b curry f x y = f (PairWord32Int32 x y) -instance Adapt Word32 Int64 where +instance AdaptPair Word32 Int64 where data Pair Word32 Int64 = PairWord32Int64 {-# UNPACK #-}!Word32 {-# UNPACK #-}!Int64 fst (PairWord32Int64 a _) = a snd (PairWord32Int64 _ b) = b curry f x y = f (PairWord32Int64 x y) -instance Adapt Word32 Word where +instance AdaptPair Word32 Word where data Pair Word32 Word = PairWord32Word {-# UNPACK #-}!Word32 {-# UNPACK #-}!Word fst (PairWord32Word a _) = a snd (PairWord32Word _ b) = b curry f x y = f (PairWord32Word x y) -instance Adapt Word32 Word8 where +instance AdaptPair Word32 Word8 where data Pair Word32 Word8 = PairWord32Word8 {-# UNPACK #-}!Word32 {-# UNPACK #-}!Word8 fst (PairWord32Word8 a _) = a snd (PairWord32Word8 _ b) = b curry f x y = f (PairWord32Word8 x y) -instance Adapt Word32 Word16 where +instance AdaptPair Word32 Word16 where data Pair Word32 Word16 = PairWord32Word16 {-# UNPACK #-}!Word32 {-# UNPACK #-}!Word16 fst (PairWord32Word16 a _) = a snd (PairWord32Word16 _ b) = b curry f x y = f (PairWord32Word16 x y) -instance Adapt Word32 Word32 where +instance AdaptPair Word32 Word32 where data Pair Word32 Word32 = PairWord32Word32 {-# UNPACK #-}!Word32 {-# UNPACK #-}!Word32 fst (PairWord32Word32 a _) = a snd (PairWord32Word32 _ b) = b curry f x y = f (PairWord32Word32 x y) -instance Adapt Word32 Word64 where +instance AdaptPair Word32 Word64 where data Pair Word32 Word64 = PairWord32Word64 {-# UNPACK #-}!Word32 {-# UNPACK #-}!Word64 fst (PairWord32Word64 a _) = a snd (PairWord32Word64 _ b) = b curry f x y = f (PairWord32Word64 x y) -instance Adapt Word32 Double where +instance AdaptPair Word32 Double where data Pair Word32 Double = PairWord32Double {-# UNPACK #-}!Word32 {-# UNPACK #-}!Double fst (PairWord32Double a _) = a snd (PairWord32Double _ b) = b curry f x y = f (PairWord32Double x y) -instance Adapt Word32 Float where +instance AdaptPair Word32 Float where data Pair Word32 Float = PairWord32Float {-# UNPACK #-}!Word32 {-# UNPACK #-}!Float fst (PairWord32Float a _) = a snd (PairWord32Float _ b) = b curry f x y = f (PairWord32Float x y) -instance Adapt Word32 Char where +instance AdaptPair Word32 Char where data Pair Word32 Char = PairWord32Char {-# UNPACK #-}!Word32 {-# UNPACK #-}!Char fst (PairWord32Char a _) = a snd (PairWord32Char _ b) = b curry f x y = f (PairWord32Char x y) -instance Adapt Word64 Int where +instance AdaptPair Word64 Int where data Pair Word64 Int = PairWord64Int {-# UNPACK #-}!Word64 {-# UNPACK #-}!Int fst (PairWord64Int a _) = a snd (PairWord64Int _ b) = b curry f x y = f (PairWord64Int x y) -instance Adapt Word64 Integer where +instance AdaptPair Word64 Integer where data Pair Word64 Integer = PairWord64Integer {-# UNPACK #-}!Word64 {-# UNPACK #-}!Integer fst (PairWord64Integer a _) = a snd (PairWord64Integer _ b) = b curry f x y = f (PairWord64Integer x y) -instance Adapt Word64 Int8 where +instance AdaptPair Word64 Int8 where data Pair Word64 Int8 = PairWord64Int8 {-# UNPACK #-}!Word64 {-# UNPACK #-}!Int8 fst (PairWord64Int8 a _) = a snd (PairWord64Int8 _ b) = b curry f x y = f (PairWord64Int8 x y) -instance Adapt Word64 Int16 where +instance AdaptPair Word64 Int16 where data Pair Word64 Int16 = PairWord64Int16 {-# UNPACK #-}!Word64 {-# UNPACK #-}!Int16 fst (PairWord64Int16 a _) = a snd (PairWord64Int16 _ b) = b curry f x y = f (PairWord64Int16 x y) -instance Adapt Word64 Int32 where +instance AdaptPair Word64 Int32 where data Pair Word64 Int32 = PairWord64Int32 {-# UNPACK #-}!Word64 {-# UNPACK #-}!Int32 fst (PairWord64Int32 a _) = a snd (PairWord64Int32 _ b) = b curry f x y = f (PairWord64Int32 x y) -instance Adapt Word64 Int64 where +instance AdaptPair Word64 Int64 where data Pair Word64 Int64 = PairWord64Int64 {-# UNPACK #-}!Word64 {-# UNPACK #-}!Int64 fst (PairWord64Int64 a _) = a snd (PairWord64Int64 _ b) = b curry f x y = f (PairWord64Int64 x y) -instance Adapt Word64 Word where +instance AdaptPair Word64 Word where data Pair Word64 Word = PairWord64Word {-# UNPACK #-}!Word64 {-# UNPACK #-}!Word fst (PairWord64Word a _) = a snd (PairWord64Word _ b) = b curry f x y = f (PairWord64Word x y) -instance Adapt Word64 Word8 where +instance AdaptPair Word64 Word8 where data Pair Word64 Word8 = PairWord64Word8 {-# UNPACK #-}!Word64 {-# UNPACK #-}!Word8 fst (PairWord64Word8 a _) = a snd (PairWord64Word8 _ b) = b curry f x y = f (PairWord64Word8 x y) -instance Adapt Word64 Word16 where +instance AdaptPair Word64 Word16 where data Pair Word64 Word16 = PairWord64Word16 {-# UNPACK #-}!Word64 {-# UNPACK #-}!Word16 fst (PairWord64Word16 a _) = a snd (PairWord64Word16 _ b) = b curry f x y = f (PairWord64Word16 x y) -instance Adapt Word64 Word32 where +instance AdaptPair Word64 Word32 where data Pair Word64 Word32 = PairWord64Word32 {-# UNPACK #-}!Word64 {-# UNPACK #-}!Word32 fst (PairWord64Word32 a _) = a snd (PairWord64Word32 _ b) = b curry f x y = f (PairWord64Word32 x y) -instance Adapt Word64 Word64 where +instance AdaptPair Word64 Word64 where data Pair Word64 Word64 = PairWord64Word64 {-# UNPACK #-}!Word64 {-# UNPACK #-}!Word64 fst (PairWord64Word64 a _) = a snd (PairWord64Word64 _ b) = b curry f x y = f (PairWord64Word64 x y) -instance Adapt Word64 Double where +instance AdaptPair Word64 Double where data Pair Word64 Double = PairWord64Double {-# UNPACK #-}!Word64 {-# UNPACK #-}!Double fst (PairWord64Double a _) = a snd (PairWord64Double _ b) = b curry f x y = f (PairWord64Double x y) -instance Adapt Word64 Float where +instance AdaptPair Word64 Float where data Pair Word64 Float = PairWord64Float {-# UNPACK #-}!Word64 {-# UNPACK #-}!Float fst (PairWord64Float a _) = a snd (PairWord64Float _ b) = b curry f x y = f (PairWord64Float x y) -instance Adapt Word64 Char where +instance AdaptPair Word64 Char where data Pair Word64 Char = PairWord64Char {-# UNPACK #-}!Word64 {-# UNPACK #-}!Char fst (PairWord64Char a _) = a snd (PairWord64Char _ b) = b curry f x y = f (PairWord64Char x y) -instance Adapt Double Int where +instance AdaptPair Double Int where data Pair Double Int = PairDoubleInt {-# UNPACK #-}!Double {-# UNPACK #-}!Int fst (PairDoubleInt a _) = a snd (PairDoubleInt _ b) = b curry f x y = f (PairDoubleInt x y) -instance Adapt Double Integer where +instance AdaptPair Double Integer where data Pair Double Integer = PairDoubleInteger {-# UNPACK #-}!Double {-# UNPACK #-}!Integer fst (PairDoubleInteger a _) = a snd (PairDoubleInteger _ b) = b curry f x y = f (PairDoubleInteger x y) -instance Adapt Double Int8 where +instance AdaptPair Double Int8 where data Pair Double Int8 = PairDoubleInt8 {-# UNPACK #-}!Double {-# UNPACK #-}!Int8 fst (PairDoubleInt8 a _) = a snd (PairDoubleInt8 _ b) = b curry f x y = f (PairDoubleInt8 x y) -instance Adapt Double Int16 where +instance AdaptPair Double Int16 where data Pair Double Int16 = PairDoubleInt16 {-# UNPACK #-}!Double {-# UNPACK #-}!Int16 fst (PairDoubleInt16 a _) = a snd (PairDoubleInt16 _ b) = b curry f x y = f (PairDoubleInt16 x y) -instance Adapt Double Int32 where +instance AdaptPair Double Int32 where data Pair Double Int32 = PairDoubleInt32 {-# UNPACK #-}!Double {-# UNPACK #-}!Int32 fst (PairDoubleInt32 a _) = a snd (PairDoubleInt32 _ b) = b curry f x y = f (PairDoubleInt32 x y) -instance Adapt Double Int64 where +instance AdaptPair Double Int64 where data Pair Double Int64 = PairDoubleInt64 {-# UNPACK #-}!Double {-# UNPACK #-}!Int64 fst (PairDoubleInt64 a _) = a snd (PairDoubleInt64 _ b) = b curry f x y = f (PairDoubleInt64 x y) -instance Adapt Double Word where +instance AdaptPair Double Word where data Pair Double Word = PairDoubleWord {-# UNPACK #-}!Double {-# UNPACK #-}!Word fst (PairDoubleWord a _) = a snd (PairDoubleWord _ b) = b curry f x y = f (PairDoubleWord x y) -instance Adapt Double Word8 where +instance AdaptPair Double Word8 where data Pair Double Word8 = PairDoubleWord8 {-# UNPACK #-}!Double {-# UNPACK #-}!Word8 fst (PairDoubleWord8 a _) = a snd (PairDoubleWord8 _ b) = b curry f x y = f (PairDoubleWord8 x y) -instance Adapt Double Word16 where +instance AdaptPair Double Word16 where data Pair Double Word16 = PairDoubleWord16 {-# UNPACK #-}!Double {-# UNPACK #-}!Word16 fst (PairDoubleWord16 a _) = a snd (PairDoubleWord16 _ b) = b curry f x y = f (PairDoubleWord16 x y) -instance Adapt Double Word32 where +instance AdaptPair Double Word32 where data Pair Double Word32 = PairDoubleWord32 {-# UNPACK #-}!Double {-# UNPACK #-}!Word32 fst (PairDoubleWord32 a _) = a snd (PairDoubleWord32 _ b) = b curry f x y = f (PairDoubleWord32 x y) -instance Adapt Double Word64 where +instance AdaptPair Double Word64 where data Pair Double Word64 = PairDoubleWord64 {-# UNPACK #-}!Double {-# UNPACK #-}!Word64 fst (PairDoubleWord64 a _) = a snd (PairDoubleWord64 _ b) = b curry f x y = f (PairDoubleWord64 x y) -instance Adapt Double Double where +instance AdaptPair Double Double where data Pair Double Double = PairDoubleDouble {-# UNPACK #-}!Double {-# UNPACK #-}!Double fst (PairDoubleDouble a _) = a snd (PairDoubleDouble _ b) = b curry f x y = f (PairDoubleDouble x y) -instance Adapt Double Float where +instance AdaptPair Double Float where data Pair Double Float = PairDoubleFloat {-# UNPACK #-}!Double {-# UNPACK #-}!Float fst (PairDoubleFloat a _) = a snd (PairDoubleFloat _ b) = b curry f x y = f (PairDoubleFloat x y) -instance Adapt Double Char where +instance AdaptPair Double Char where data Pair Double Char = PairDoubleChar {-# UNPACK #-}!Double {-# UNPACK #-}!Char fst (PairDoubleChar a _) = a snd (PairDoubleChar _ b) = b curry f x y = f (PairDoubleChar x y) -instance Adapt Float Int where +instance AdaptPair Float Int where data Pair Float Int = PairFloatInt {-# UNPACK #-}!Float {-# UNPACK #-}!Int fst (PairFloatInt a _) = a snd (PairFloatInt _ b) = b curry f x y = f (PairFloatInt x y) -instance Adapt Float Integer where +instance AdaptPair Float Integer where data Pair Float Integer = PairFloatInteger {-# UNPACK #-}!Float {-# UNPACK #-}!Integer fst (PairFloatInteger a _) = a snd (PairFloatInteger _ b) = b curry f x y = f (PairFloatInteger x y) -instance Adapt Float Int8 where +instance AdaptPair Float Int8 where data Pair Float Int8 = PairFloatInt8 {-# UNPACK #-}!Float {-# UNPACK #-}!Int8 fst (PairFloatInt8 a _) = a snd (PairFloatInt8 _ b) = b curry f x y = f (PairFloatInt8 x y) -instance Adapt Float Int16 where +instance AdaptPair Float Int16 where data Pair Float Int16 = PairFloatInt16 {-# UNPACK #-}!Float {-# UNPACK #-}!Int16 fst (PairFloatInt16 a _) = a snd (PairFloatInt16 _ b) = b curry f x y = f (PairFloatInt16 x y) -instance Adapt Float Int32 where +instance AdaptPair Float Int32 where data Pair Float Int32 = PairFloatInt32 {-# UNPACK #-}!Float {-# UNPACK #-}!Int32 fst (PairFloatInt32 a _) = a snd (PairFloatInt32 _ b) = b curry f x y = f (PairFloatInt32 x y) -instance Adapt Float Int64 where +instance AdaptPair Float Int64 where data Pair Float Int64 = PairFloatInt64 {-# UNPACK #-}!Float {-# UNPACK #-}!Int64 fst (PairFloatInt64 a _) = a snd (PairFloatInt64 _ b) = b curry f x y = f (PairFloatInt64 x y) -instance Adapt Float Word where +instance AdaptPair Float Word where data Pair Float Word = PairFloatWord {-# UNPACK #-}!Float {-# UNPACK #-}!Word fst (PairFloatWord a _) = a snd (PairFloatWord _ b) = b curry f x y = f (PairFloatWord x y) -instance Adapt Float Word8 where +instance AdaptPair Float Word8 where data Pair Float Word8 = PairFloatWord8 {-# UNPACK #-}!Float {-# UNPACK #-}!Word8 fst (PairFloatWord8 a _) = a snd (PairFloatWord8 _ b) = b curry f x y = f (PairFloatWord8 x y) -instance Adapt Float Word16 where +instance AdaptPair Float Word16 where data Pair Float Word16 = PairFloatWord16 {-# UNPACK #-}!Float {-# UNPACK #-}!Word16 fst (PairFloatWord16 a _) = a snd (PairFloatWord16 _ b) = b curry f x y = f (PairFloatWord16 x y) -instance Adapt Float Word32 where +instance AdaptPair Float Word32 where data Pair Float Word32 = PairFloatWord32 {-# UNPACK #-}!Float {-# UNPACK #-}!Word32 fst (PairFloatWord32 a _) = a snd (PairFloatWord32 _ b) = b curry f x y = f (PairFloatWord32 x y) -instance Adapt Float Word64 where +instance AdaptPair Float Word64 where data Pair Float Word64 = PairFloatWord64 {-# UNPACK #-}!Float {-# UNPACK #-}!Word64 fst (PairFloatWord64 a _) = a snd (PairFloatWord64 _ b) = b curry f x y = f (PairFloatWord64 x y) -instance Adapt Float Double where +instance AdaptPair Float Double where data Pair Float Double = PairFloatDouble {-# UNPACK #-}!Float {-# UNPACK #-}!Double fst (PairFloatDouble a _) = a snd (PairFloatDouble _ b) = b curry f x y = f (PairFloatDouble x y) -instance Adapt Float Float where +instance AdaptPair Float Float where data Pair Float Float = PairFloatFloat {-# UNPACK #-}!Float {-# UNPACK #-}!Float fst (PairFloatFloat a _) = a snd (PairFloatFloat _ b) = b curry f x y = f (PairFloatFloat x y) -instance Adapt Float Char where +instance AdaptPair Float Char where data Pair Float Char = PairFloatChar {-# UNPACK #-}!Float {-# UNPACK #-}!Char fst (PairFloatChar a _) = a snd (PairFloatChar _ b) = b curry f x y = f (PairFloatChar x y) -instance Adapt Char Int where +instance AdaptPair Char Int where data Pair Char Int = PairCharInt {-# UNPACK #-}!Char {-# UNPACK #-}!Int fst (PairCharInt a _) = a snd (PairCharInt _ b) = b curry f x y = f (PairCharInt x y) -instance Adapt Char Integer where +instance AdaptPair Char Integer where data Pair Char Integer = PairCharInteger {-# UNPACK #-}!Char {-# UNPACK #-}!Integer fst (PairCharInteger a _) = a snd (PairCharInteger _ b) = b curry f x y = f (PairCharInteger x y) -instance Adapt Char Int8 where +instance AdaptPair Char Int8 where data Pair Char Int8 = PairCharInt8 {-# UNPACK #-}!Char {-# UNPACK #-}!Int8 fst (PairCharInt8 a _) = a snd (PairCharInt8 _ b) = b curry f x y = f (PairCharInt8 x y) -instance Adapt Char Int16 where +instance AdaptPair Char Int16 where data Pair Char Int16 = PairCharInt16 {-# UNPACK #-}!Char {-# UNPACK #-}!Int16 fst (PairCharInt16 a _) = a snd (PairCharInt16 _ b) = b curry f x y = f (PairCharInt16 x y) -instance Adapt Char Int32 where +instance AdaptPair Char Int32 where data Pair Char Int32 = PairCharInt32 {-# UNPACK #-}!Char {-# UNPACK #-}!Int32 fst (PairCharInt32 a _) = a snd (PairCharInt32 _ b) = b curry f x y = f (PairCharInt32 x y) -instance Adapt Char Int64 where +instance AdaptPair Char Int64 where data Pair Char Int64 = PairCharInt64 {-# UNPACK #-}!Char {-# UNPACK #-}!Int64 fst (PairCharInt64 a _) = a snd (PairCharInt64 _ b) = b curry f x y = f (PairCharInt64 x y) -instance Adapt Char Word where +instance AdaptPair Char Word where data Pair Char Word = PairCharWord {-# UNPACK #-}!Char {-# UNPACK #-}!Word fst (PairCharWord a _) = a snd (PairCharWord _ b) = b curry f x y = f (PairCharWord x y) -instance Adapt Char Word8 where +instance AdaptPair Char Word8 where data Pair Char Word8 = PairCharWord8 {-# UNPACK #-}!Char {-# UNPACK #-}!Word8 fst (PairCharWord8 a _) = a snd (PairCharWord8 _ b) = b curry f x y = f (PairCharWord8 x y) -instance Adapt Char Word16 where +instance AdaptPair Char Word16 where data Pair Char Word16 = PairCharWord16 {-# UNPACK #-}!Char {-# UNPACK #-}!Word16 fst (PairCharWord16 a _) = a snd (PairCharWord16 _ b) = b curry f x y = f (PairCharWord16 x y) -instance Adapt Char Word32 where +instance AdaptPair Char Word32 where data Pair Char Word32 = PairCharWord32 {-# UNPACK #-}!Char {-# UNPACK #-}!Word32 fst (PairCharWord32 a _) = a snd (PairCharWord32 _ b) = b curry f x y = f (PairCharWord32 x y) -instance Adapt Char Word64 where +instance AdaptPair Char Word64 where data Pair Char Word64 = PairCharWord64 {-# UNPACK #-}!Char {-# UNPACK #-}!Word64 fst (PairCharWord64 a _) = a snd (PairCharWord64 _ b) = b curry f x y = f (PairCharWord64 x y) -instance Adapt Char Double where +instance AdaptPair Char Double where data Pair Char Double = PairCharDouble {-# UNPACK #-}!Char {-# UNPACK #-}!Double fst (PairCharDouble a _) = a snd (PairCharDouble _ b) = b curry f x y = f (PairCharDouble x y) -instance Adapt Char Float where +instance AdaptPair Char Float where data Pair Char Float = PairCharFloat {-# UNPACK #-}!Char {-# UNPACK #-}!Float fst (PairCharFloat a _) = a snd (PairCharFloat _ b) = b curry f x y = f (PairCharFloat x y) -instance Adapt Char Char where +instance AdaptPair Char Char where data Pair Char Char = PairCharChar {-# UNPACK #-}!Char {-# UNPACK #-}!Char fst (PairCharChar a _) = a snd (PairCharChar _ b) = b diff --git a/adaptive-containers.cabal b/adaptive-containers.cabal --- a/adaptive-containers.cabal +++ b/adaptive-containers.cabal @@ -1,18 +1,30 @@ name: adaptive-containers -version: 0.1 +version: 0.2 homepage: http://code.haskell.org/~dons/code/adaptive-containers synopsis: Self optimizing container types description: Self optimizing polymorphic container types. - - We use type families to specialize polymorphic container types to - specific representations via class-associated data types. - + . + Adaptive containers are polymorphic container types that use + class associated data types to specialize particular element types + to a more efficient container representation. The resulting + structures tend to be both more time and space efficient. + . A self-optimizing pair, for example, will unpack the constructors, yielding a representation for (Int,Char) requiring 8 bytes, instead of 24. - - Currently supported adaptive types: pairs + . + This difference can be visualized, here for the value: + . + > [ (x,y) | x <- [1..3], y <- [x..3] ] + . + * A regular list of pairs + . + * An adaptive list of pairs + . + * An adaptive list of adaptive pairs + . + Currently supported adaptive types: pairs, lists category: Data license: BSD3 @@ -24,8 +36,11 @@ library exposed-modules: Data.Adaptive.Tuple + Data.Adaptive.List - ghc-options: -O2 -funbox-strict-fields -Wall + ghc-options: -O2 + -fdicts-cheap + -Wall ghc-prof-options: -prof -auto-all extensions: TypeFamilies, diff --git a/scripts/derive-list.hs b/scripts/derive-list.hs new file mode 100644 --- /dev/null +++ b/scripts/derive-list.hs @@ -0,0 +1,143 @@ + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS -fglasgow-exts #-} + +module AdaptiveDerive where + +import Data.Generics +import Data.List +import Text.PrettyPrint +import Control.Monad + +import Data.Int +import Data.Word + +{- + +instance Adapt Int Int where + + data Pair Int Int = PIntInt {-# UNPACK #-}!Int {-# UNPACK #-}!Int + + fst (PIntInt a _) = a + snd (PIntInt _ b) = b + curry f x y = f (PIntInt x y) + uncurry f p = f (fst p) (snd p) + + -} + +------------------------------------------------------------------------ + +main = sequence_ . intersperse (putStrLn "") $ + [ deriveM t | Box t <- types ] + +data Box = forall a. (Typeable a, Data a) => Box a + +types :: [Box] +types = [ Box (undefined :: Int) + , Box (undefined :: Integer) + , Box (undefined :: Int8) + , Box (undefined :: Int16) + , Box (undefined :: Int32) + , Box (undefined :: Int64) + , Box (undefined :: Word) + , Box (undefined :: Word8) + , Box (undefined :: Word16) + , Box (undefined :: Word32) + , Box (undefined :: Word64) + , Box (undefined :: Double) + , Box (undefined :: Float) + , Box (undefined :: Char) + ] + +------------------------------------------------------------------------ + +deriveM :: forall a . (Typeable a, Data a) => a -> IO () +deriveM (a :: a) = putStrLn $ derive (undefined :: a) + +{- +instance AdaptList Int where + data List Int = EmptyInt | ConsInt {-# UNPACK #-}!Int (List Int) + + empty = EmptyInt + cons x xs = ConsInt x xs + null EmptyInt = True + null _ = False + head EmptyInt = errorEmptyList "head" + head (ConsInt x _) = x + tail EmptyInt = errorEmptyList "tail" + tail (ConsInt _ xs) = xs +-} + +derive :: (Typeable a, Data a) => a -> String +derive x = render $ + + hang + (hsep [text "instance", text "AdaptList", text type_x, text "where"]) + 4 + (vcat [ + hsep [ text "data" + , text "List" + , text type_x + , char '=' + , text myemptyconstr + , char '|' + , text myconsconstr + , text "{-# UNPACK #-}!" <> text type_x + , parens (text "List" <+> text type_x) + ] + + ,hsep [ text "empty" + ,char '=' + , text myemptyconstr] + + ,hsep [ text "cons" + ,char '=' + , text myconsconstr] + + ,hsep [ text "null" + , text myemptyconstr + ,char '=' + , text "True"] + ,hsep [ text "null" + , char '_' + ,char '=' + , text "False"] + + ,hsep [ text "head" + , text myemptyconstr + ,char '=' + , text "errorEmptyList \"head\"" + ] + ,hsep [ text "head" + , parens (text myconsconstr <+> char 'x' <+> char '_') + ,char '=' + , char 'x'] + + ,hsep [ text "tail" + , text myemptyconstr + ,char '=' + , text "errorEmptyList \"tail\"" + ] + ,hsep [ text "tail" + , parens (text myconsconstr <+> char '_' <+> char 'x') + ,char '=' + , char 'x'] + + + ]) + + + where + type_x = inst_a + + myemptyconstr = "Empty" ++ type_x + myconsconstr = "Cons" ++ type_x + + inst_a = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters + where (typeName,typeChildren) = splitTyConApp (typeOf x) + typeLetters = take nTypeChildren manyLetters + nTypeChildren = length typeChildren + wrap x = if nTypeChildren > 0 then "("++x++")" else x + + manyLetters = map (:[]) ['a'..'z'] diff --git a/scripts/derive-pair.hs b/scripts/derive-pair.hs new file mode 100644 --- /dev/null +++ b/scripts/derive-pair.hs @@ -0,0 +1,115 @@ + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS -fglasgow-exts #-} + +module AdaptiveDerive where + +import Data.Generics +import Data.List +import Text.PrettyPrint +import Control.Monad + +import Data.Int +import Data.Word + +{- + +instance Adapt Int Int where + + data Pair Int Int = PIntInt {-# UNPACK #-}!Int {-# UNPACK #-}!Int + + fst (PIntInt a _) = a + snd (PIntInt _ b) = b + curry f x y = f (PIntInt x y) + uncurry f p = f (fst p) (snd p) + + -} + +------------------------------------------------------------------------ + +main = sequence_ . intersperse (putStrLn "") $ + [ deriveM t u + | Box t <- types + , Box u <- types ] + +data Box = forall a. (Typeable a, Data a) => Box a + +types :: [Box] +types = [ Box (undefined :: Int) + , Box (undefined :: Integer) + , Box (undefined :: Int8) + , Box (undefined :: Int16) + , Box (undefined :: Int32) + , Box (undefined :: Int64) + , Box (undefined :: Word) + , Box (undefined :: Word8) + , Box (undefined :: Word16) + , Box (undefined :: Word32) + , Box (undefined :: Word64) + , Box (undefined :: Double) + , Box (undefined :: Float) + , Box (undefined :: Char) + ] + +------------------------------------------------------------------------ + +deriveM :: forall a b . (Typeable a, Data a, Typeable b, Data b) => a -> b -> IO () +deriveM (a :: a) (b :: b) = putStrLn $ derive (undefined :: a) (undefined :: b) + + +derive :: (Typeable a, Data a, Typeable b, Data b) => a -> b -> String +derive x y = render $ + + hang + (hsep [text "instance", text "AdaptPair", text type_x, text type_y, text "where"]) + 4 + (vcat [ + hsep [ text "data" + , text "Pair" + , text type_x + , text type_y + , char '=' + , text myconstr + , text "{-# UNPACK #-}!" <> text type_x + , text "{-# UNPACK #-}!" <> text type_y + ] + + ,hsep [text "fst" + , parens (text myconstr <+> text "a _") + , char '=' , char 'a' ] + + ,hsep [text "snd" + , parens (text myconstr <+> text "_ b") + , char '=' , char 'b' ] + + ,hsep [ text "curry" + , char 'f' + , char 'x' + , char 'y' + , char '=' + , char 'f' <+> parens (text myconstr <+> text "x y") + ] + + ]) + + where + type_x = inst_a + + type_y = inst_b + + myconstr = "Pair" ++ type_x ++ type_y + + inst_a = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters + where (typeName,typeChildren) = splitTyConApp (typeOf x) + typeLetters = take nTypeChildren manyLetters + nTypeChildren = length typeChildren + wrap x = if nTypeChildren > 0 then "("++x++")" else x + + inst_b = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters + where (typeName,typeChildren) = splitTyConApp (typeOf y) + typeLetters = take nTypeChildren manyLetters + nTypeChildren = length typeChildren + wrap x = if nTypeChildren > 0 then "("++x++")" else x + + manyLetters = map (:[]) ['a'..'z'] diff --git a/scripts/derive.hs b/scripts/derive.hs deleted file mode 100644 --- a/scripts/derive.hs +++ /dev/null @@ -1,115 +0,0 @@ - -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# OPTIONS -fglasgow-exts #-} - -module AdaptiveDerive where - -import Data.Generics -import Data.List -import Text.PrettyPrint -import Control.Monad - -import Data.Int -import Data.Word - -{- - -instance Adapt Int Int where - - data Pair Int Int = PIntInt {-# UNPACK #-}!Int {-# UNPACK #-}!Int - - fst (PIntInt a _) = a - snd (PIntInt _ b) = b - curry f x y = f (PIntInt x y) - uncurry f p = f (fst p) (snd p) - - -} - ------------------------------------------------------------------------- - -main = sequence_ . intersperse (putStrLn "") $ - [ deriveM t u - | Box t <- types - , Box u <- types ] - -data Box = forall a. (Typeable a, Data a) => Box a - -types :: [Box] -types = [ Box (undefined :: Int) - , Box (undefined :: Integer) - , Box (undefined :: Int8) - , Box (undefined :: Int16) - , Box (undefined :: Int32) - , Box (undefined :: Int64) - , Box (undefined :: Word) - , Box (undefined :: Word8) - , Box (undefined :: Word16) - , Box (undefined :: Word32) - , Box (undefined :: Word64) - , Box (undefined :: Double) - , Box (undefined :: Float) - , Box (undefined :: Char) - ] - ------------------------------------------------------------------------- - -deriveM :: forall a b . (Typeable a, Data a, Typeable b, Data b) => a -> b -> IO () -deriveM (a :: a) (b :: b) = putStrLn $ derive (undefined :: a) (undefined :: b) - - -derive :: (Typeable a, Data a, Typeable b, Data b) => a -> b -> String -derive x y = render $ - - hang - (hsep [text "instance", text "Adapt", text type_x, text type_y, text "where"]) - 4 - (vcat [ - hsep [ text "data" - , text "Pair" - , text type_x - , text type_y - , char '=' - , text myconstr - , text "{-# UNPACK #-}!" <> text type_x - , text "{-# UNPACK #-}!" <> text type_y - ] - - ,hsep [text "fst" - , parens (text myconstr <+> text "a _") - , char '=' , char 'a' ] - - ,hsep [text "snd" - , parens (text myconstr <+> text "_ b") - , char '=' , char 'b' ] - - ,hsep [ text "curry" - , char 'f' - , char 'x' - , char 'y' - , char '=' - , char 'f' <+> parens (text myconstr <+> text "x y") - ] - - ]) - - where - type_x = inst_a - - type_y = inst_b - - myconstr = "Pair" ++ type_x ++ type_y - - inst_a = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters - where (typeName,typeChildren) = splitTyConApp (typeOf x) - typeLetters = take nTypeChildren manyLetters - nTypeChildren = length typeChildren - wrap x = if nTypeChildren > 0 then "("++x++")" else x - - inst_b = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters - where (typeName,typeChildren) = splitTyConApp (typeOf y) - typeLetters = take nTypeChildren manyLetters - nTypeChildren = length typeChildren - wrap x = if nTypeChildren > 0 then "("++x++")" else x - - manyLetters = map (:[]) ['a'..'z'] diff --git a/tests/A.hs b/tests/A.hs new file mode 100644 --- /dev/null +++ b/tests/A.hs @@ -0,0 +1,11 @@ +import System.Environment +import qualified Data.Adaptive.List as L +import qualified Data.Adaptive.Tuple as L + +main = do + [n] <- mapM readIO =<< getArgs + print $ L.maximum . L.take (n-1) . L.map (\p -> L.pair (L.fst p *2) (L.snd p *4)) $ + L.zip + (L.replicate n n :: L.List Int) + (L.replicate (n-1) n :: L.List Int) + diff --git a/tests/B.hs b/tests/B.hs new file mode 100644 --- /dev/null +++ b/tests/B.hs @@ -0,0 +1,9 @@ +import System.Environment + +main = do + [n] <- mapM readIO =<< getArgs + print $ maximum . take (n-1) . map (\(a,b) -> ((a *2),(b *4))) $ + zip + (replicate n n :: [Int]) + (replicate (n-1) n :: [Int]) + diff --git a/tests/list.hs b/tests/list.hs new file mode 100644 --- /dev/null +++ b/tests/list.hs @@ -0,0 +1,10 @@ + +module M where + +import Prelude hiding (last, replicate, zip) +import Data.Adaptive.List +import Data.Adaptive.Tuple + +f :: List (Pair Int Int) +f = zip (replicate 10 (8 :: Int)) + (replicate 10 (7 :: Int))