haskus-utils-data 1.1.1 → 1.2

raw patch · 9 files changed

+742/−293 lines, 9 filesdep +doctestdep +ghc-primdep ~basedep ~haskus-utils-typesPVP ok

version bump matches the API change (PVP)

Dependencies added: doctest, ghc-prim

Dependency ranges changed: base, haskus-utils-types

API changes (from Hackage documentation)

Files

• haskus-utils-data.cabal +26/−13
• src/lib/Haskus/Utils/Either.hs +8/−0
• src/lib/Haskus/Utils/Functor.hs +178/−2
• src/lib/Haskus/Utils/HList.hs +70/−39
• src/lib/Haskus/Utils/InfList.hs +39/−0
• src/lib/Haskus/Utils/List.hs +135/−5
• src/lib/Haskus/Utils/Monad.hs +4/−4
• src/lib/Haskus/Utils/Tuple.hs +255/−230
• src/tests/Main.hs +27/−0

@@ -1,15 +1,15 @@ name:                haskus-utils-data-version:             1.1.1-synopsis:            Haskus utility modules+version:             1.2+synopsis:            Haskus data utility modules license:             BSD3 license-file:        LICENSE author:              Sylvain Henry maintainer:          sylvain@haskus.fr homepage:            http://www.haskus.org-copyright:           Sylvain Henry 2018-category:            System+copyright:           Sylvain Henry 2020+category:            Data build-type:          Simple-cabal-version:       >=1.20+cabal-version:       1.20  description:    Haskus data utility modules@@ -21,26 +21,39 @@ library   exposed-modules:     Haskus.Utils.Monad+    Haskus.Utils.InfList     Haskus.Utils.HList     Haskus.Utils.Functor     Haskus.Utils.List     Haskus.Utils.Map     Haskus.Utils.Map.Strict     Haskus.Utils.Maybe+    Haskus.Utils.Either     Haskus.Utils.Tuple    other-modules:    build-depends:       -      base                      >= 4.9 && < 5-   ,  haskus-utils-types        >= 1.1-   ,  extra                     >= 1.4-   ,  recursion-schemes         >= 5.0-   ,  containers                >= 0.5-   ,  mtl                       >= 2.2-   ,  transformers              >= 0.4+     base                       >= 4.9 && < 5+   , haskus-utils-types         >= 1.5+   , extra                      >= 1.4+   , recursion-schemes          >= 5.0+   , containers                 >= 0.5+   , mtl                        >= 2.2+   , transformers               >= 0.4+   , ghc-prim -  build-tools:    ghc-options:          -Wall   default-language:     Haskell2010   hs-source-dirs:       src/lib++test-suite tests+   type:                exitcode-stdio-1.0+   main-is:             Main.hs+   hs-source-dirs:      src/tests/+   ghc-options:         -Wall -threaded+   default-language:    Haskell2010++   build-depends:+         base >= 4.9 && < 5+      ,  doctest

@@ -0,0 +1,8 @@+module Haskus.Utils.Either+   ( module Data.Either+   , module Data.Either.Extra+   )+where++import Data.Either+import Data.Either.Extra

@@ -1,7 +1,183 @@--- | Functor helpers+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}++-- | Functor and recursion schemes+--+-- Simple API is intended to be easier to understand (e.g. they don't use+-- xxmorphism and xxxalgebra jargon but tree-traversal-like terms). module Haskus.Utils.Functor-   ( module Data.Functor.Foldable+   ( -- * Simple API+     BottomUpT+   , bottomUp+   , BottomUpOrigT+   , bottomUpOrig+   , TopDownStopT+   , topDownStop+   -- * Recursion schemes+   , module Data.Functor.Classes+   , module Data.Functor.Foldable+   , Algebra+   , CoAlgebra+   , RAlgebra+   , RCoAlgebra+   -- * Higher-order recursion schemes+   , type (~>)+   , type NatM+   , HBase+   , HAlgebra+   , HAlgebraM+   , HGAlgebra+   , HGAlgebraM+   , HCoalgebra+   , HCoalgebraM+   , HGCoalgebra+   , HGCoalgebraM+   , HFunctor (..)+   , HFoldable (..)+   , HTraversable (..)+   , HRecursive (..)+   , HCorecursive (..)+   , hhylo+   , hcataM+   , hlambek+   , hpara+   , hparaM+   , hanaM+   , hcolambek+   , hapo+   , hapoM+   , hhyloM    ) where  import Data.Functor.Foldable hiding (ListF(..))+import Data.Functor.Classes+import Data.Functor.Sum+import Data.Functor.Product+import Control.Monad+import Control.Applicative++import Haskus.Utils.Types (Type)++-------------------------------------------+-- Simple API+-------------------------------------------++type BottomUpT       a f = f a -> a+type BottomUpOrigT t a f = f (t,a) -> a+type TopDownStopT    a f = f a -> Either (f a) a++-- | Bottom-up traversal (catamorphism)+bottomUp :: (Recursive t) => (Base t a -> a) -> t -> a+bottomUp f t = cata f t++-- | Bottom-up traversal with original value (paramorphism)+bottomUpOrig :: (Recursive t) => (Base t (t,a) -> a) -> t -> a+bottomUpOrig f t = para f t++-- | Perform a top-down traversal+--+-- Right: stop the traversal ("right" value obtained)+-- Left: continue the traversal recursively on the new value+topDownStop :: (Recursive t, Corecursive t) => (Base t t -> Either (Base t t) t) -> t -> t+topDownStop f t = go t+   where+      go w = case f (project w) of+         Right x -> x                 -- stop here+         Left  x -> embed (fmap go x) -- continue recursively+++-------------------------------------------+-- Recursion schemes+-------------------------------------------++type Algebra    f a   = f a -> a+type CoAlgebra  f a   = a -> f a+type RAlgebra   f t a = f (t, a) -> a+type RCoAlgebra f t a = a -> f (Either t a)+++-------------------------------------------+-- Higher-order+-------------------------------------------+++type f ~> g = forall a. f a -> g a+type NatM m f g = forall a. f a -> m (g a)++type family HBase (h :: k -> Type) :: (k -> Type) -> (k -> Type)++type HAlgebra h f = h f ~> f+type HAlgebraM m h f = NatM m (h f) f+type HGAlgebra w h a = h (w a) ~> a+type HGAlgebraM w m h a = NatM m (h (w a)) a++type HCoalgebra h f = f ~> h f+type HCoalgebraM m h f = NatM m f (h f)+type HGCoalgebra m h a = a ~> h (m a)+type HGCoalgebraM n m h a = NatM m a (h (n a))++class HFunctor (h :: (k -> Type) -> (k -> Type)) where+  hfmap :: (f ~> g) -> h f ~> h g++class HFunctor h => HFoldable (h :: (k -> Type) -> (k -> Type)) where+  hfoldMap :: Monoid m => (forall b. f b -> m) -> h f a -> m++class HFoldable h => HTraversable (h :: (k -> Type) -> (k -> Type))  where+  htraverse :: Applicative e => NatM e f g -> NatM e (h f) (h g)++class HFunctor (HBase h) => HRecursive (h :: k -> Type) where+  hproject :: HCoalgebra (HBase h) h++  hcata :: HAlgebra (HBase h) f -> h ~> f+  hcata algebra = algebra . hfmap (hcata algebra) . hproject++class HFunctor (HBase h) => HCorecursive (h :: k -> Type) where+  hembed :: HAlgebra (HBase h) h++  hana :: HCoalgebra (HBase h) f -> f ~> h+  hana coalgebra = hembed . hfmap (hana coalgebra) . coalgebra++hhylo :: HFunctor f => HAlgebra f b -> HCoalgebra f a -> a ~> b+hhylo f g = f . hfmap (hhylo f g) . g++hcataM :: (Monad m, HTraversable (HBase h), HRecursive h) => HAlgebraM m (HBase h) f -> h a -> m (f a)+hcataM f = f <=< htraverse (hcataM f) . hproject++hlambek :: (HRecursive h, HCorecursive h) => HCoalgebra (HBase h) h+hlambek = hcata (hfmap hembed)++hpara :: (HFunctor (HBase h), HRecursive h) => HGAlgebra (Product h) (HBase h) a -> h ~> a+hpara phi = phi . hfmap (\a -> Pair a (hpara phi a)) . hproject++hparaM :: (HTraversable (HBase h), HRecursive h, Monad m) => HGAlgebraM (Product h) m (HBase h) a -> NatM m h a+hparaM phiM = phiM <=< htraverse (\a -> liftA2 Pair (pure a) (hparaM phiM a)) . hproject++hanaM :: (Monad m, HTraversable (HBase h), HCorecursive h) => HCoalgebraM m (HBase h) f -> f a -> m (h a)+hanaM f = fmap hembed . htraverse (hanaM f) <=< f++hcolambek :: HRecursive h => HCorecursive h => HAlgebra (HBase h) h+hcolambek = hana (hfmap hproject)++hapo :: HCorecursive h => HGCoalgebra (Sum h) (HBase h) a -> a ~> h+hapo psi = hembed . hfmap (coproduct id (hapo psi)) . psi+  where+    coproduct f _ (InL a) = f a+    coproduct _ g (InR a) = g a++hapoM :: (HCorecursive h, HTraversable (HBase h), Monad m) => HGCoalgebraM (Sum h) m (HBase h) a -> NatM m a h+hapoM psiM = fmap hembed . htraverse (coproduct pure (hapoM psiM)) <=< psiM+  where+    coproduct f _ (InL a) = f a+    coproduct _ g (InR a) = g a++hhyloM :: (HTraversable t, Monad m) => HAlgebraM m t h -> HCoalgebraM m t f -> f a -> m (h a)+hhyloM f g = f <=< htraverse(hhyloM f g) <=< g

@@ -13,7 +13,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE StandaloneDeriving #-} --- | Heterogeneous list utils+-- | Heterogeneous list module Haskus.Utils.HList    ( HList (..)    , hHead@@ -22,7 +22,7 @@    , hAppend    , HFoldr' (..)    , HFoldl' (..)-   , HTuple' (..)+   , HTuple (..)    , Apply (..)    , HZipList    , hZipList@@ -36,7 +36,6 @@  import Haskus.Utils.Tuple import Haskus.Utils.Types-import Haskus.Utils.Types.List  -- | Heterogeneous list data family HList (l :: [*])@@ -199,54 +198,86 @@ -- * Conversion to and from tuples  -- | Convert between hlists and tuples-class HTuple' v t | v -> t, t -> v where+class HTuple v where    -- | Convert an heterogeneous list into a tuple-   hToTuple'   :: HList v -> t+   hToTuple   :: HList v -> Tuple v        -- | Convert a tuple into an heterogeneous list-   hFromTuple' :: t -> HList v+   hFromTuple :: Tuple v -> HList v  -instance HTuple' '[] () where-    hToTuple' HNil = ()-    hFromTuple' () = HNil+instance HTuple '[] where+   hToTuple HNil = ()+   hFromTuple () = HNil -instance HTuple' '[a] (Single a) where-    hToTuple' (a `HCons` HNil) = Single a-    hFromTuple' (Single a) = a `HCons` HNil+instance HTuple '[a] where+   hToTuple (a `HCons` HNil)+      = Unit a+   hFromTuple (Unit a)+      = a `HCons` HNil -instance HTuple' '[a,b] (a,b) where-    hToTuple' (a `HCons` b `HCons` HNil) = (a,b)-    hFromTuple' (a,b) = a `HCons` b `HCons` HNil+instance HTuple '[a,b] where+   hToTuple (a `HCons` b `HCons` HNil)+      = (a,b)+   hFromTuple (a,b)+      = a `HCons` b `HCons` HNil -instance HTuple' '[a,b,c] (a,b,c) where-    hToTuple' (a `HCons` b `HCons` c `HCons` HNil) = (a,b,c)-    hFromTuple' (a,b,c) = a `HCons` b `HCons` c `HCons` HNil+instance HTuple '[a,b,c] where+   hToTuple (a `HCons` b `HCons` c `HCons` HNil)+      = (a,b,c)+   hFromTuple (a,b,c)+      = a `HCons` b `HCons` c `HCons` HNil -instance HTuple' '[a,b,c,d] (a,b,c,d) where-    hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` HNil) = (a,b,c,d)-    hFromTuple' (a,b,c,d) = a `HCons` b `HCons` c `HCons` d `HCons` HNil+instance HTuple '[a,b,c,d] where+   hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` HNil)+      = (a,b,c,d)+   hFromTuple (a,b,c,d)+      = a `HCons` b `HCons` c `HCons` d `HCons` HNil -instance HTuple' '[a,b,c,d,e] (a,b,c,d,e) where-    hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil) = (a,b,c,d,e)-    hFromTuple' (a,b,c,d,e) = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil+instance HTuple '[a,b,c,d,e] where+   hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil)+      = (a,b,c,d,e)+   hFromTuple (a,b,c,d,e)+      = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil -instance HTuple' '[a,b,c,d,e,f] (a,b,c,d,e,f) where-    hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil) = (a,b,c,d,e,f)-    hFromTuple' (a,b,c,d,e,f) = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil+instance HTuple '[a,b,c,d,e,f] where+   hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil)+      = (a,b,c,d,e,f)+   hFromTuple (a,b,c,d,e,f)+      = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -instance HTuple' '[a,b,c,d,e,f,g] (a,b,c,d,e,f,g) where-    hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` HNil) = (a,b,c,d,e,f,g)-    hFromTuple' (a,b,c,d,e,f,g) = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` HNil+instance HTuple '[a,b,c,d,e,f,g] where+   hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` HNil)+      = (a,b,c,d,e,f,g)+   hFromTuple (a,b,c,d,e,f,g)+      = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` HNil -instance HTuple' '[a,b,c,d,e,f,g,h] (a,b,c,d,e,f,g,h) where-    hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` HNil) = (a,b,c,d,e,f,g,h)-    hFromTuple' (a,b,c,d,e,f,g,h) = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` HNil+instance HTuple '[a,b,c,d,e,f,g,h] where+   hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` HNil)+      = (a,b,c,d,e,f,g,h)+   hFromTuple (a,b,c,d,e,f,g,h)+      = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` HNil -instance HTuple' '[a,b,c,d,e,f,g,h,i] (a,b,c,d,e,f,g,h,i) where-    hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` HNil) = (a,b,c,d,e,f,g,h,i)-    hFromTuple' (a,b,c,d,e,f,g,h,i) = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` HNil+instance HTuple '[a,b,c,d,e,f,g,h,i] where+   hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` HNil)+      = (a,b,c,d,e,f,g,h,i)+   hFromTuple (a,b,c,d,e,f,g,h,i)+      = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` HNil -instance HTuple' '[a,b,c,d,e,f,g,h,i,j] (a,b,c,d,e,f,g,h,i,j) where-    hToTuple' (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` j `HCons` HNil) = (a,b,c,d,e,f,g,h,i,j)-    hFromTuple' (a,b,c,d,e,f,g,h,i,j) = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` j `HCons` HNil+instance HTuple '[a,b,c,d,e,f,g,h,i,j] where+   hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` j `HCons` HNil)+      = (a,b,c,d,e,f,g,h,i,j)+   hFromTuple (a,b,c,d,e,f,g,h,i,j)+      = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` j `HCons` HNil++instance HTuple '[a,b,c,d,e,f,g,h,i,j,k] where+   hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` j `HCons` k `HCons` HNil)+      = (a,b,c,d,e,f,g,h,i,j,k)+   hFromTuple (a,b,c,d,e,f,g,h,i,j,k)+      = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` j `HCons` k `HCons` HNil++instance HTuple '[a,b,c,d,e,f,g,h,i,j,k,l] where+   hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` j `HCons` k `HCons` l `HCons` HNil)+      = (a,b,c,d,e,f,g,h,i,j,k,l)+   hFromTuple (a,b,c,d,e,f,g,h,i,j,k,l)+      = a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` g `HCons` h `HCons` i `HCons` j `HCons` k `HCons` l `HCons` HNil

@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}++-- | Infinite list+module Haskus.Utils.InfList+   ( InfList (..)+   , toList+   , repeat+   , take+   , replicate+   )+where++import Prelude hiding (take,repeat,replicate)++-- | An infinite list+data InfList a+   = a :> InfList a+   deriving (Functor,Foldable)++-- | Convert to a standard list+toList :: InfList a -> [a]+toList (a :> as) = a : toList as++-- | Take for infinite list+take :: Word -> InfList a -> [a]+take 0 _         = []+take n (x :> xs) = x : take (n-1) xs++-- | Repeat for infinite list+repeat :: a -> InfList a+repeat a = go+   where+      go = a :> go++-- | Replicate for infinite list+replicate :: Word -> a -> InfList a -> InfList a+replicate 0 _ xs = xs+replicate n a xs = a :> replicate (n-1) a xs

@@ -1,16 +1,146 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}++-- | List utils module Haskus.Utils.List-   ( checkLength-   , module Data.List-   , module Data.List.Extra+   ( at+   , unsafeAt+   , checkLength+   , (++)+   , replicate+   , drop+   , length+   , take+   , chunksOf+   , pick1+   , enumList+   , zipLeftWith+   , zipRightWith+   , L.partition+   , L.nub+   , L.sort+   , L.intersperse+   , L.foldl'+   , L.head+   , L.tail+   , L.zipWith+   , L.repeat+   , L.nubOn+   , L.nubBy+   , L.sortOn+   , L.sortBy+   , L.split+   , L.splitOn+   , L.groupOn+   , L.groupBy+   , L.transpose+   , (L.\\)+   , L.intersect+   , L.find+   , L.zip3+   , L.zip4+   , L.zip5+   , L.zip6+   , L.zip7+   , L.stripPrefix+   , L.isPrefixOf+   , L.deleteBy+   , L.isSuffixOf+   , L.elem+   , L.notElem    ) where -import Data.List-import Data.List.Extra+import Prelude hiding (replicate, length, drop, take) +import qualified Data.List as L+import qualified Data.List.Extra as L++-- | Safely index into a list+--+-- >>> [0,1,2,3] `at` 10+-- Nothing+--+-- >>> [0,1,2,3] `at` 2+-- Just 2+at :: [a] -> Word -> Maybe a+{-# INLINABLE at #-}+at = go+   where+      go []       _ = Nothing+      go (x:_xs)  0 = Just x+      go (_x:xs) !n = go xs (n-1)++-- | Unsafe `a`+--+-- >>> [0,1,2,3] `unsafeAt` 2+-- 2+unsafeAt :: [a] -> Word -> a+{-# INLINABLE unsafeAt #-}+unsafeAt vs k = go vs k+   where+      go []       _ = error ("Unsafe list index too large: " ++ show k)+      go (x:_xs)  0 = x+      go (_x:xs) !n = go xs (n-1)+ -- | Check that a list has the given length (support infinite lists) checkLength :: Word -> [a] -> Bool checkLength 0 []     = True checkLength 0 _      = False checkLength _ []     = False checkLength i (_:xs) = checkLength (i-1) xs++-- | Replicate+replicate :: Word -> a -> [a]+replicate n a = L.replicate (fromIntegral n) a++-- | Take+take :: Word -> [a] -> [a]+take n = L.take (fromIntegral n)++-- | Length+length :: Foldable t => t a -> Word+length = fromIntegral . L.length++-- | Drop+drop :: Word -> [a] -> [a]+drop n = L.drop (fromIntegral n)++-- | Split a list into chunks of a given size. The last chunk may contain fewer+-- than n elements.+chunksOf :: Word -> [a] -> [[a]]+chunksOf n = L.chunksOf (fromIntegral n)+++-- | Pick each element and return the element and the rest of the list+--+-- >>> pick1 [1,2,3,4]+-- [(1,[2,3,4]),(2,[1,3,4]),(3,[1,2,4]),(4,[1,2,3])]+pick1 :: [a] -> [(a,[a])]+pick1 = go []+   where+      go _  []     = []+      go ys (x:xs) = (x,reverse ys++xs) : go (x:ys) xs++-- | Get members of a bounded enum in a list+--+-- >>> :set -XTypeApplications+-- >>> data Letters = A | B | C | D deriving (Bounded,Enum,Show)+-- >>> enumList @Letters+-- [A,B,C,D]+enumList :: forall a. (Bounded a,Enum a) => [a]+enumList = enumFrom minBound++-- | Zip left with something extracted from each value+--+-- >>> zipLeftWith odd [0..5]+-- [(False,0),(True,1),(False,2),(True,3),(False,4),(True,5)]+zipLeftWith :: (a -> b) -> [a] -> [(b,a)]+zipLeftWith f xs = fmap f xs `zip` xs++-- | Zip right with something extracted from each value+--+-- >>> zipRightWith odd [0..5]+-- [(0,False),(1,True),(2,False),(3,True),(4,False),(5,True)]+zipRightWith :: (a -> b) -> [a] -> [(a,b)]+zipRightWith f xs = xs `zip` fmap f xs

@@ -25,19 +25,19 @@    liftWith2 :: (forall c. (a -> b -> IO c) -> IO c) -> (a -> b -> m e) -> m e  instance MonadInIO IO where-   {-# INLINE liftWith #-}+   {-# INLINABLE liftWith #-}    liftWith = id -   {-# INLINE liftWith2 #-}+   {-# INLINABLE liftWith2 #-}    liftWith2 = id  instance MonadInIO m => MonadInIO (StateT s m) where-   {-# INLINE liftWith #-}+   {-# INLINABLE liftWith #-}    liftWith wth f =       StateT $ \s -> do          liftWith wth (\a -> runStateT (f a) s) -   {-# INLINE liftWith2 #-}+   {-# INLINABLE liftWith2 #-}    liftWith2 wth f =       StateT $ \s ->          liftWith2 wth (\a b -> runStateT (f a b) s)

@@ -6,314 +6,257 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilyDependencies #-}  -- | Tuple helpers module Haskus.Utils.Tuple    ( uncurry3    , uncurry4+   , uncurry5+   , uncurry6+   , uncurry7    , take4    , fromTuple4    , module Data.Tuple-   , Single (..)-   , TupleToList-   , ListToTuple+   , Unit (..)+   , Tuple+   , Tuple#+   , TypeReps    , ExtractTuple (..)-   , TupleHead (..)+   , TupleCon (..)+   , tupleHead    , TupleTail (..)    , TupleCons (..)    , ReorderTuple (..)    ) where +import GHC.Tuple+import GHC.Exts import Data.Tuple import Haskus.Utils.Types --- | Uncurry specialised for triple-uncurry3 :: (a -> b -> c -> e) -> (a,b,c) -> e-{-# INLINE uncurry3 #-}-uncurry3 f (a,b,c) = f a b c+-- | Uncurry3+uncurry3 :: (a -> b -> c -> r) -> (a,b,c) -> r+{-# INLINABLE uncurry3 #-}+uncurry3 fn (a,b,c) = fn a b c --- | Uncurry specialised for quadruple-uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e-{-# INLINE uncurry4 #-}-uncurry4 f (a,b,c,d) = f a b c d+-- | Uncurry4+uncurry4 :: (a -> b -> c -> d -> r) -> (a,b,c,d) -> r+{-# INLINABLE uncurry4 #-}+uncurry4 fn (a,b,c,d) = fn a b c d +-- | Uncurry5+uncurry5 :: (a -> b -> c -> d -> e -> r) -> (a,b,c,d,e) -> r+{-# INLINABLE uncurry5 #-}+uncurry5 fn (a,b,c,d,e) = fn a b c d e +-- | Uncurry6+uncurry6 :: (a -> b -> c -> d -> e -> f -> r) -> (a,b,c,d,e,f) -> r+{-# INLINABLE uncurry6 #-}+uncurry6 fn (a,b,c,d,e,f) = fn a b c d e f++-- | Uncurry7+uncurry7 :: (a -> b -> c -> d -> e -> f -> g -> r) -> (a,b,c,d,e,f,g) -> r+{-# INLINABLE uncurry7 #-}+uncurry7 fn (a,b,c,d,e,f,g) = fn a b c d e f g++ -- | Take specialised for quadruple take4 :: [a] -> (a,a,a,a)-{-# INLINE take4 #-}+{-# INLINABLE take4 #-} take4 [a,b,c,d] = (a,b,c,d) take4 _         = error "take4: invalid list (exactly 4 elements required)"   -- | toList for quadruple fromTuple4 :: (a,a,a,a) -> [a]-{-# INLINE fromTuple4 #-}+{-# INLINABLE fromTuple4 #-} fromTuple4 (a,b,c,d) = [a,b,c,d] --- | Singleton type-newtype Single a = Single a deriving (Show,Eq)---type family TupleToList (t :: k) :: [k] where-   TupleToList (Single a)                                            = '[a]-   TupleToList (a,b)                                                 = '[a,b]-   TupleToList (a,b,c)                                               = '[a,b,c]-   TupleToList (a,b,c,d)                                             = '[a,b,c,d]-   TupleToList (a,b,c,d,e)                                           = '[a,b,c,d,e]-   TupleToList (a,b,c,d,e,f)                                         = '[a,b,c,d,e,f]-   TupleToList (a,b,c,d,e,f,g)                                       = '[a,b,c,d,e,f,g]-   TupleToList (a,b,c,d,e,f,g,h)                                     = '[a,b,c,d,e,f,g,h]-   TupleToList (a,b,c,d,e,f,g,h,i)                                   = '[a,b,c,d,e,f,g,h,i]-   TupleToList (a,b,c,d,e,f,g,h,i,j)                                 = '[a,b,c,d,e,f,g,h,i,j]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k)                               = '[a,b,c,d,e,f,g,h,i,j,k]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l)                             = '[a,b,c,d,e,f,g,h,i,j,k,l]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m)                           = '[a,b,c,d,e,f,g,h,i,j,k,l,m]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n)                         = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)                       = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)                     = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q)                   = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r)                 = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s)               = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t)             = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u)           = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v)         = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w)       = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x)     = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y)   = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y]-   TupleToList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z]--type family ListToTuple (t :: [k]) :: k where-   ListToTuple '[a]                                                   = Single a-   ListToTuple '[a,b]                                                 = (a,b)-   ListToTuple '[a,b,c]                                               = (a,b,c)-   ListToTuple '[a,b,c,d]                                             = (a,b,c,d)-   ListToTuple '[a,b,c,d,e]                                           = (a,b,c,d,e)-   ListToTuple '[a,b,c,d,e,f]                                         = (a,b,c,d,e,f)-   ListToTuple '[a,b,c,d,e,f,g]                                       = (a,b,c,d,e,f,g)-   ListToTuple '[a,b,c,d,e,f,g,h]                                     = (a,b,c,d,e,f,g,h)-   ListToTuple '[a,b,c,d,e,f,g,h,i]                                   = (a,b,c,d,e,f,g,h,i)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j]                                 = (a,b,c,d,e,f,g,h,i,j)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k]                               = (a,b,c,d,e,f,g,h,i,j,k)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l]                             = (a,b,c,d,e,f,g,h,i,j,k,l)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m]                           = (a,b,c,d,e,f,g,h,i,j,k,l,m)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n]                         = (a,b,c,d,e,f,g,h,i,j,k,l,m,n)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o]                       = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p]                     = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q]                   = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r]                 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s]               = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t]             = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u]           = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v]         = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w]       = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x]     = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y]   = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y)-   ListToTuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)- -- | Extract a tuple value statically-class ExtractTuple (n :: Nat) t x | n t -> x where+class ExtractTuple (n :: Nat) xs where    -- | Extract a tuple value by type-level index-   tupleN :: t -> x+   tupleN :: Tuple xs -> Index n xs -instance ExtractTuple 0 (Single t) t where-   {-# INLINE tupleN #-}-   tupleN (Single t) = t+instance ExtractTuple 0 '[a] where+   {-# INLINABLE tupleN #-}+   tupleN (Unit t) = t -instance ExtractTuple 0 (e0, e1) e0 where-   {-# INLINE tupleN #-}+instance ExtractTuple 0 '[e0,e1] where+   {-# INLINABLE tupleN #-}    tupleN (t,_) = t -instance ExtractTuple 1 (e0, e1) e1 where-   {-# INLINE tupleN #-}+instance ExtractTuple 1 '[e0,e1] where+   {-# INLINABLE tupleN #-}    tupleN (_,t) = t -instance ExtractTuple 0 (e0, e1, e2) e0 where-   {-# INLINE tupleN #-}+instance ExtractTuple 0 '[e0,e1,e2] where+   {-# INLINABLE tupleN #-}    tupleN (t,_,_) = t -instance ExtractTuple 1 (e0, e1, e2) e1 where-   {-# INLINE tupleN #-}+instance ExtractTuple 1 '[e0,e1,e2] where+   {-# INLINABLE tupleN #-}    tupleN (_,t,_) = t -instance ExtractTuple 2 (e0, e1, e2) e2 where-   {-# INLINE tupleN #-}+instance ExtractTuple 2 '[e0,e1,e2] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,t) = t -instance ExtractTuple 0 (e0, e1, e2, e3) e0 where-   {-# INLINE tupleN #-}+instance ExtractTuple 0 '[e0,e1,e2,e3] where+   {-# INLINABLE tupleN #-}    tupleN (t,_,_,_) = t -instance ExtractTuple 1 (e0, e1, e2, e3) e1 where-   {-# INLINE tupleN #-}+instance ExtractTuple 1 '[e0,e1,e2,e3] where+   {-# INLINABLE tupleN #-}    tupleN (_,t,_,_) = t -instance ExtractTuple 2 (e0, e1, e2, e3) e2 where-   {-# INLINE tupleN #-}+instance ExtractTuple 2 '[e0,e1,e2,e3] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,t,_) = t -instance ExtractTuple 3 (e0, e1, e2, e3) e3 where-   {-# INLINE tupleN #-}+instance ExtractTuple 3 '[e0,e1,e2,e3] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,t) = t  -instance ExtractTuple 0 (e0, e1, e2, e3, e4) e0 where-   {-# INLINE tupleN #-}+instance ExtractTuple 0 '[e0,e1,e2,e3,e4] where+   {-# INLINABLE tupleN #-}    tupleN (t,_,_,_,_) = t -instance ExtractTuple 1 (e0, e1, e2, e3, e4) e1 where-   {-# INLINE tupleN #-}+instance ExtractTuple 1 '[e0,e1,e2,e3,e4] where+   {-# INLINABLE tupleN #-}    tupleN (_,t,_,_,_) = t -instance ExtractTuple 2 (e0, e1, e2, e3, e4) e2 where-   {-# INLINE tupleN #-}+instance ExtractTuple 2 '[e0,e1,e2,e3,e4] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,t,_,_) = t -instance ExtractTuple 3 (e0, e1, e2, e3, e4) e3 where-   {-# INLINE tupleN #-}+instance ExtractTuple 3 '[e0,e1,e2,e3,e4] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,t,_) = t -instance ExtractTuple 4 (e0, e1, e2, e3, e4) e4 where-   {-# INLINE tupleN #-}+instance ExtractTuple 4 '[e0,e1,e2,e3,e4] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,_,t) = t  -instance ExtractTuple 0 (e0, e1, e2, e3, e4, e5) e0 where-   {-# INLINE tupleN #-}+instance ExtractTuple 0 '[e0,e1,e2,e3,e4,e5] where+   {-# INLINABLE tupleN #-}    tupleN (t,_,_,_,_,_) = t -instance ExtractTuple 1 (e0, e1, e2, e3, e4, e5) e1 where-   {-# INLINE tupleN #-}+instance ExtractTuple 1 '[e0,e1,e2,e3,e4,e5] where+   {-# INLINABLE tupleN #-}    tupleN (_,t,_,_,_,_) = t -instance ExtractTuple 2 (e0, e1, e2, e3, e4, e5) e2 where-   {-# INLINE tupleN #-}+instance ExtractTuple 2 '[e0,e1,e2,e3,e4,e5] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,t,_,_,_) = t -instance ExtractTuple 3 (e0, e1, e2, e3, e4, e5) e3 where-   {-# INLINE tupleN #-}+instance ExtractTuple 3 '[e0,e1,e2,e3,e4,e5] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,t,_,_) = t -instance ExtractTuple 4 (e0, e1, e2, e3, e4, e5) e4 where-   {-# INLINE tupleN #-}+instance ExtractTuple 4 '[e0,e1,e2,e3,e4,e5] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,_,t,_) = t -instance ExtractTuple 5 (e0, e1, e2, e3, e4, e5) e5 where-   {-# INLINE tupleN #-}+instance ExtractTuple 5 '[e0,e1,e2,e3,e4,e5] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,_,_,t) = t  -instance ExtractTuple 0 (e0, e1, e2, e3, e4, e5, e6) e0 where-   {-# INLINE tupleN #-}+instance ExtractTuple 0 '[e0,e1,e2,e3,e4,e5,e6] where+   {-# INLINABLE tupleN #-}    tupleN (t,_,_,_,_,_,_) = t -instance ExtractTuple 1 (e0, e1, e2, e3, e4, e5, e6) e1 where-   {-# INLINE tupleN #-}+instance ExtractTuple 1 '[e0,e1,e2,e3,e4,e5,e6] where+   {-# INLINABLE tupleN #-}    tupleN (_,t,_,_,_,_,_) = t -instance ExtractTuple 2 (e0, e1, e2, e3, e4, e5, e6) e2 where-   {-# INLINE tupleN #-}+instance ExtractTuple 2 '[e0,e1,e2,e3,e4,e5,e6] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,t,_,_,_,_) = t -instance ExtractTuple 3 (e0, e1, e2, e3, e4, e5, e6) e3 where-   {-# INLINE tupleN #-}+instance ExtractTuple 3 '[e0,e1,e2,e3,e4,e5,e6] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,t,_,_,_) = t -instance ExtractTuple 4 (e0, e1, e2, e3, e4, e5, e6) e4 where-   {-# INLINE tupleN #-}+instance ExtractTuple 4 '[e0,e1,e2,e3,e4,e5,e6] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,_,t,_,_) = t -instance ExtractTuple 5 (e0, e1, e2, e3, e4, e5, e6) e5 where-   {-# INLINE tupleN #-}+instance ExtractTuple 5 '[e0,e1,e2,e3,e4,e5,e6] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,_,_,t,_) = t -instance ExtractTuple 6 (e0, e1, e2, e3, e4, e5, e6) e6 where-   {-# INLINE tupleN #-}+instance ExtractTuple 6 '[e0,e1,e2,e3,e4,e5,e6] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,_,_,_,t) = t  -instance ExtractTuple 0 (e0, e1, e2, e3, e4, e5, e6, e7) e0 where-   {-# INLINE tupleN #-}+instance ExtractTuple 0 '[e0,e1,e2,e3,e4,e5,e6,e7] where+   {-# INLINABLE tupleN #-}    tupleN (t,_,_,_,_,_,_,_) = t -instance ExtractTuple 1 (e0, e1, e2, e3, e4, e5, e6, e7) e1 where-   {-# INLINE tupleN #-}+instance ExtractTuple 1 '[e0,e1,e2,e3,e4,e5,e6,e7] where+   {-# INLINABLE tupleN #-}    tupleN (_,t,_,_,_,_,_,_) = t -instance ExtractTuple 2 (e0, e1, e2, e3, e4, e5, e6, e7) e2 where-   {-# INLINE tupleN #-}+instance ExtractTuple 2 '[e0,e1,e2,e3,e4,e5,e6,e7] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,t,_,_,_,_,_) = t -instance ExtractTuple 3 (e0, e1, e2, e3, e4, e5, e6, e7) e3 where-   {-# INLINE tupleN #-}+instance ExtractTuple 3 '[e0,e1,e2,e3,e4,e5,e6,e7] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,t,_,_,_,_) = t -instance ExtractTuple 4 (e0, e1, e2, e3, e4, e5, e6, e7) e4 where-   {-# INLINE tupleN #-}+instance ExtractTuple 4 '[e0,e1,e2,e3,e4,e5,e6,e7] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,_,t,_,_,_) = t -instance ExtractTuple 5 (e0, e1, e2, e3, e4, e5, e6, e7) e5 where-   {-# INLINE tupleN #-}+instance ExtractTuple 5 '[e0,e1,e2,e3,e4,e5,e6,e7] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,_,_,t,_,_) = t -instance ExtractTuple 6 (e0, e1, e2, e3, e4, e5, e6, e7) e6 where-   {-# INLINE tupleN #-}+instance ExtractTuple 6 '[e0,e1,e2,e3,e4,e5,e6,e7] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,_,_,_,t,_) = t -instance ExtractTuple 7 (e0, e1, e2, e3, e4, e5, e6, e7) e7 where-   {-# INLINE tupleN #-}+instance ExtractTuple 7 '[e0,e1,e2,e3,e4,e5,e6,e7] where+   {-# INLINABLE tupleN #-}    tupleN (_,_,_,_,_,_,_,t) = t --class TupleHead ts ts' | ts -> ts' where-   tupleHead :: ts -> ts'--instance TupleHead (Single a) a where-   {-# INLINE tupleHead #-}-   tupleHead (Single a) = a--instance TupleHead (a,b) a where-   {-# INLINE tupleHead #-}-   tupleHead (a,_) = a--instance TupleHead (a,b,c) a where-   {-# INLINE tupleHead #-}-   tupleHead (a,_,_) = a--instance TupleHead (a,b,c,d) a where-   {-# INLINE tupleHead #-}-   tupleHead (a,_,_,_) = a--instance TupleHead (a,b,c,d,e) a where-   {-# INLINE tupleHead #-}-   tupleHead (a,_,_,_,_) = a--instance TupleHead (a,b,c,d,e,f) a where-   {-# INLINE tupleHead #-}-   tupleHead (a,_,_,_,_,_) = a-+-- | Get first element of the tuple+tupleHead :: forall xs. ExtractTuple 0 xs => Tuple xs -> Index 0 xs+tupleHead = tupleN @0  class TupleTail ts ts' | ts -> ts' where    tupleTail :: ts -> ts' -instance TupleTail (a,b) (Single b) where-   {-# INLINE tupleTail #-}-   tupleTail (_,b) = Single b+instance TupleTail (a,b) (Unit b) where+   {-# INLINABLE tupleTail #-}+   tupleTail (_,b) = Unit b  instance TupleTail (a,b,c) (b,c) where-   {-# INLINE tupleTail #-}+   {-# INLINABLE tupleTail #-}    tupleTail (_,b,c) = (b,c)  instance TupleTail (a,b,c,d) (b,c,d) where-   {-# INLINE tupleTail #-}+   {-# INLINABLE tupleTail #-}    tupleTail (_,b,c,d) = (b,c,d)  instance TupleTail (a,b,c,d,e) (b,c,d,e) where-   {-# INLINE tupleTail #-}+   {-# INLINABLE tupleTail #-}    tupleTail (_,b,c,d,e) = (b,c,d,e)  instance TupleTail (a,b,c,d,e,f) (b,c,d,e,f) where-   {-# INLINE tupleTail #-}+   {-# INLINABLE tupleTail #-}    tupleTail (_,b,c,d,e,f) = (b,c,d,e,f)  @@ -321,24 +264,24 @@ class TupleCons t ts ts' | t ts -> ts' where    tupleCons :: t -> ts -> ts' -instance TupleCons a (Single b) (a,b) where-   {-# INLINE tupleCons #-}-   tupleCons a (Single b) = (a,b)+instance TupleCons a (Unit b) (a,b) where+   {-# INLINABLE tupleCons #-}+   tupleCons a (Unit b) = (a,b)  instance TupleCons a (b,c) (a,b,c) where-   {-# INLINE tupleCons #-}+   {-# INLINABLE tupleCons #-}    tupleCons a (b,c) = (a,b,c)  instance TupleCons a (b,c,d) (a,b,c,d) where-   {-# INLINE tupleCons #-}+   {-# INLINABLE tupleCons #-}    tupleCons a (b,c,d) = (a,b,c,d)  instance TupleCons a (b,c,d,e) (a,b,c,d,e) where-   {-# INLINE tupleCons #-}+   {-# INLINABLE tupleCons #-}    tupleCons a (b,c,d,e) = (a,b,c,d,e)  instance TupleCons a (b,c,d,e,f) (a,b,c,d,e,f) where-   {-# INLINE tupleCons #-}+   {-# INLINABLE tupleCons #-}    tupleCons a (b,c,d,e,f) = (a,b,c,d,e,f)  @@ -348,156 +291,238 @@    tupleReorder :: t1 -> t2  -instance ReorderTuple (Single a) (Single a) where-   {-# INLINE tupleReorder #-}+instance ReorderTuple (Unit a) (Unit a) where+   {-# INLINABLE tupleReorder #-}    tupleReorder = id  instance ReorderTuple (a,b) (a,b) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder = id  instance ReorderTuple (a,b,c) (a,b,c) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder = id  instance ReorderTuple (a,b,c,d) (a,b,c,d) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder = id  instance ReorderTuple (a,b,c,d,e) (a,b,c,d,e) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder = id  instance ReorderTuple (a,b,c,d,e,f) (a,b,c,d,e,f) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder = id  instance ReorderTuple (a,b,c,d,e,f,g) (a,b,c,d,e,f,g) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder = id  instance ReorderTuple (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g,h) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder = id  instance ReorderTuple (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h,i) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder = id  instance ReorderTuple (a,b,c,d,e,f,g,h,i,j) (a,b,c,d,e,f,g,h,i,j) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder = id   instance ReorderTuple (a,b) (b,a) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b) = (b,a)  instance ReorderTuple (a,b,c) (a,c,b) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c) = (a,c,b)  instance ReorderTuple (a,b,c) (b,a,c) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c) = (b,a,c)  instance ReorderTuple (a,b,c) (b,c,a) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c) = (b,c,a)  instance ReorderTuple (a,b,c) (c,a,b) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c) = (c,a,b)  instance ReorderTuple (a,b,c) (c,b,a) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c) = (c,b,a)  instance ReorderTuple (b,c,d) (x,y,z) => ReorderTuple (a,b,c,d) (a,x,y,z) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d) = let (x,y,z) = tupleReorder (b,c,d) in (a,x,y,z)  instance ReorderTuple (a,c,d) (x,y,z) => ReorderTuple (a,b,c,d) (x,b,y,z) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d) = let (x,y,z) = tupleReorder (a,c,d) in (x,b,y,z)  instance ReorderTuple (a,b,d) (x,y,z) => ReorderTuple (a,b,c,d) (x,y,c,z) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d) = let (x,y,z) = tupleReorder (a,b,d) in (x,y,c,z)  instance ReorderTuple (a,b,c) (x,y,z) => ReorderTuple (a,b,c,d) (x,y,z,d) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d) = let (x,y,z) = tupleReorder (a,b,c) in (x,y,z,d)  instance ReorderTuple (b,c,d,e) (x,y,z,w) => ReorderTuple (a,b,c,d,e) (a,x,y,z,w) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e) = let (x,y,z,w) = tupleReorder (b,c,d,e) in (a,x,y,z,w)  instance ReorderTuple (a,c,d,e) (x,y,z,w) => ReorderTuple (a,b,c,d,e) (x,b,y,z,w) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e) = let (x,y,z,w) = tupleReorder (a,c,d,e) in (x,b,y,z,w)  instance ReorderTuple (a,b,d,e) (x,y,z,w) => ReorderTuple (a,b,c,d,e) (x,y,c,z,w) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e) = let (x,y,z,w) = tupleReorder (a,b,d,e) in (x,y,c,z,w)  instance ReorderTuple (a,b,c,e) (x,y,z,w) => ReorderTuple (a,b,c,d,e) (x,y,z,d,w) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e) = let (x,y,z,w) = tupleReorder (a,b,c,e) in (x,y,z,d,w)  instance ReorderTuple (a,b,c,d) (x,y,z,w) => ReorderTuple (a,b,c,d,e) (x,y,z,w,e) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e) = let (x,y,z,w) = tupleReorder (a,b,c,d) in (x,y,z,w,e)  instance ReorderTuple (b,c,d,e,f) (x,y,z,w,v) => ReorderTuple (a,b,c,d,e,f) (a,x,y,z,w,v) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e,f) = let (x,y,z,w,v) = tupleReorder (b,c,d,e,f) in (a,x,y,z,w,v)  instance ReorderTuple (a,c,d,e,f) (x,y,z,w,v) => ReorderTuple (a,b,c,d,e,f) (x,b,y,z,w,v) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e,f) = let (x,y,z,w,v) = tupleReorder (a,c,d,e,f) in (x,b,y,z,w,v)  instance ReorderTuple (a,b,d,e,f) (x,y,z,w,v) => ReorderTuple (a,b,c,d,e,f) (x,y,c,z,w,v) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e,f) = let (x,y,z,w,v) = tupleReorder (a,b,d,e,f) in (x,y,c,z,w,v)  instance ReorderTuple (a,b,c,e,f) (x,y,z,w,v) => ReorderTuple (a,b,c,d,e,f) (x,y,z,d,w,v) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e,f) = let (x,y,z,w,v) = tupleReorder (a,b,c,e,f) in (x,y,z,d,w,v)  instance ReorderTuple (a,b,c,d,f) (x,y,z,w,v) => ReorderTuple (a,b,c,d,e,f) (x,y,z,w,e,v) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e,f) = let (x,y,z,w,v) = tupleReorder (a,b,c,d,f) in (x,y,z,w,e,v)  instance ReorderTuple (a,b,c,d,e) (x,y,z,w,v) => ReorderTuple (a,b,c,d,e,f) (x,y,z,w,v,f) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e,f) = let (x,y,z,w,v) = tupleReorder (a,b,c,d,e) in (x,y,z,w,v,f)   instance ReorderTuple (b,c,d,e,f,g) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (a,x,y,z,w,v,u) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (b,c,d,e,f,g) in (a,x,y,z,w,v,u)  instance ReorderTuple (a,c,d,e,f,g) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (x,b,y,z,w,v,u) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (a,c,d,e,f,g) in (x,b,y,z,w,v,u)  instance ReorderTuple (a,b,d,e,f,g) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (x,y,c,z,w,v,u) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (a,b,d,e,f,g) in (x,y,c,z,w,v,u)  instance ReorderTuple (a,b,c,e,f,g) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (x,y,z,d,w,v,u) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (a,b,c,e,f,g) in (x,y,z,d,w,v,u)  instance ReorderTuple (a,b,c,d,f,g) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (x,y,z,w,e,v,u) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (a,b,c,d,f,g) in (x,y,z,w,e,v,u)  instance ReorderTuple (a,b,c,d,e,g) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (x,y,z,w,v,f,u) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (a,b,c,d,e,g) in (x,y,z,w,v,f,u)  instance ReorderTuple (a,b,c,d,e,f) (x,y,z,w,v,u) => ReorderTuple (a,b,c,d,e,f,g) (x,y,z,w,v,u,g) where-   {-# INLINE tupleReorder #-}+   {-# INLINABLE tupleReorder #-}    tupleReorder (a,b,c,d,e,f,g) = let (x,y,z,w,v,u) = tupleReorder (a,b,c,d,e,f) in (x,y,z,w,v,u,g)++type family TupleFun r xs where+   TupleFun r '[]      = r+   TupleFun r (x:xs)   = x -> (TupleFun r xs)++-- | Create a Tuple+class TupleCon xs where+   -- | Create a Tuple+   tupleCon :: TupleFun (Tuple xs) xs++instance TupleCon '[] where+   tupleCon = ()++instance TupleCon '[a] where+   tupleCon = Unit++instance TupleCon '[a,b] where+   tupleCon = (,)++instance TupleCon '[a,b,c] where+   tupleCon = (,,)++instance TupleCon '[a,b,c,d] where+   tupleCon = (,,,)++instance TupleCon '[a,b,c,d,e] where+   tupleCon = (,,,,)++instance TupleCon '[a,b,c,d,e,f] where+   tupleCon = (,,,,,)++-- | Boxed tuple+--+-- TODO: put this family into GHC+type family Tuple xs = t | t -> xs where+   Tuple '[]                                                    = ()+   Tuple '[a]                                                   = Unit a+   Tuple '[a,b]                                                 = (a,b)+   Tuple '[a,b,c]                                               = (a,b,c)+   Tuple '[a,b,c,d]                                             = (a,b,c,d)+   Tuple '[a,b,c,d,e]                                           = (a,b,c,d,e)+   Tuple '[a,b,c,d,e,f]                                         = (a,b,c,d,e,f)+   Tuple '[a,b,c,d,e,f,g]                                       = (a,b,c,d,e,f,g)+   Tuple '[a,b,c,d,e,f,g,h]                                     = (a,b,c,d,e,f,g,h)+   Tuple '[a,b,c,d,e,f,g,h,i]                                   = (a,b,c,d,e,f,g,h,i)+   Tuple '[a,b,c,d,e,f,g,h,i,j]                                 = (a,b,c,d,e,f,g,h,i,j)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k]                               = (a,b,c,d,e,f,g,h,i,j,k)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l]                             = (a,b,c,d,e,f,g,h,i,j,k,l)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m]                           = (a,b,c,d,e,f,g,h,i,j,k,l,m)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n]                         = (a,b,c,d,e,f,g,h,i,j,k,l,m,n)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o]                       = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p]                     = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q]                   = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r]                 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s]               = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t]             = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u]           = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v]         = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w]       = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x]     = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y]   = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y)+   Tuple '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z] = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+++type family TypeReps xs where+   TypeReps '[]                 = '[]+   TypeReps ((a::TYPE k) ': as) = k ': TypeReps as++-- | Unboxed tuple+--+-- TODO: put this family into GHC+type family Tuple# xs = (t :: TYPE ('TupleRep (TypeReps xs))) | t -> xs where+   Tuple# '[]                  = (##)+   Tuple# '[a]                 = (# a #)+   Tuple# '[a,b]               = (# a,b #)+   Tuple# '[a,b,c]             = (# a,b,c #)+   Tuple# '[a,b,c,d]           = (# a,b,c,d #)+   Tuple# '[a,b,c,d,e]         = (# a,b,c,d,e #)+   Tuple# '[a,b,c,d,e,f]       = (# a,b,c,d,e,f #)+   Tuple# '[a,b,c,d,e,f,g]     = (# a,b,c,d,e,f,g #)+   Tuple# '[a,b,c,d,e,f,g,h]   = (# a,b,c,d,e,f,g,h #)+   Tuple# '[a,b,c,d,e,f,g,h,i] = (# a,b,c,d,e,f,g,h,i #)

@@ -0,0 +1,27 @@+{-# LANGUAGE LambdaCase #-}++import Test.DocTest++import Control.Exception+import System.Exit++main :: IO ()+main = wrapTests+   [ title "DOCTEST" $ doctest ["src/lib/"]+   ]++title :: String -> IO () -> IO ()+title s m = do+   putStrLn ""+   putStrLn (replicate 30 '=')+   putStrLn s+   putStrLn (replicate 30 '=')+   m++wrap :: IO () -> IO Bool+wrap m = (m >> return True) `catch` (\e -> return (e == ExitSuccess))++wrapTests :: [IO ()] -> IO ()+wrapTests ts = (and <$> traverse wrap ts) >>= \case+   True  -> title "SUMMARY" exitSuccess+   False -> title "SUMMARY" exitFailure