diff --git a/haskus-utils-data.cabal b/haskus-utils-data.cabal --- a/haskus-utils-data.cabal +++ b/haskus-utils-data.cabal @@ -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 diff --git a/src/lib/Haskus/Utils/Either.hs b/src/lib/Haskus/Utils/Either.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Either.hs @@ -0,0 +1,8 @@ +module Haskus.Utils.Either + ( module Data.Either + , module Data.Either.Extra + ) +where + +import Data.Either +import Data.Either.Extra diff --git a/src/lib/Haskus/Utils/Functor.hs b/src/lib/Haskus/Utils/Functor.hs --- a/src/lib/Haskus/Utils/Functor.hs +++ b/src/lib/Haskus/Utils/Functor.hs @@ -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 diff --git a/src/lib/Haskus/Utils/HList.hs b/src/lib/Haskus/Utils/HList.hs --- a/src/lib/Haskus/Utils/HList.hs +++ b/src/lib/Haskus/Utils/HList.hs @@ -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 diff --git a/src/lib/Haskus/Utils/InfList.hs b/src/lib/Haskus/Utils/InfList.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/InfList.hs @@ -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 diff --git a/src/lib/Haskus/Utils/List.hs b/src/lib/Haskus/Utils/List.hs --- a/src/lib/Haskus/Utils/List.hs +++ b/src/lib/Haskus/Utils/List.hs @@ -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 diff --git a/src/lib/Haskus/Utils/Monad.hs b/src/lib/Haskus/Utils/Monad.hs --- a/src/lib/Haskus/Utils/Monad.hs +++ b/src/lib/Haskus/Utils/Monad.hs @@ -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) diff --git a/src/lib/Haskus/Utils/Tuple.hs b/src/lib/Haskus/Utils/Tuple.hs --- a/src/lib/Haskus/Utils/Tuple.hs +++ b/src/lib/Haskus/Utils/Tuple.hs @@ -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 #) diff --git a/src/tests/Main.hs b/src/tests/Main.hs new file mode 100644 --- /dev/null +++ b/src/tests/Main.hs @@ -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