diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2013-2017, Haskus organization +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + * Neither the name of Sylvain Henry nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/haskus-utils-data.cabal b/haskus-utils-data.cabal new file mode 100644 --- /dev/null +++ b/haskus-utils-data.cabal @@ -0,0 +1,41 @@ +name: haskus-utils-data +version: 1.0 +cabal-version: >=1.20 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: Sylvain Henry 2018 +maintainer: sylvain@haskus.fr +homepage: http://www.haskus.org +synopsis: Haskus utility modules +description: + Haskus data utility modules +category: System +author: Sylvain Henry + +source-repository head + type: git + location: git://github.com/haskus/haskus-utils.git + +library + exposed-modules: + Haskus.Utils.Monad + Haskus.Utils.HList + Haskus.Utils.Functor + Haskus.Utils.List + Haskus.Utils.Map + Haskus.Utils.Map.Strict + Haskus.Utils.Maybe + Haskus.Utils.Tuple + build-depends: + base >=4.9 && <4.12, + haskus-utils-types ==1.0.*, + extra >=1.4 && <1.7, + recursion-schemes ==5.0.*, + containers ==0.5.*, + mtl ==2.2.*, + transformers >=0.4 && <0.6 + default-language: Haskell2010 + hs-source-dirs: src/lib + ghc-options: -Wall + diff --git a/src/lib/Haskus/Utils/Functor.hs b/src/lib/Haskus/Utils/Functor.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Functor.hs @@ -0,0 +1,7 @@ +-- | Functor helpers +module Haskus.Utils.Functor + ( module Data.Functor.Foldable + ) +where + +import Data.Functor.Foldable diff --git a/src/lib/Haskus/Utils/HList.hs b/src/lib/Haskus/Utils/HList.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/HList.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | Heterogeneous list utils +module Haskus.Utils.HList + ( HList (..) + , hHead + , hTail + , hLength + , hAppend + , HFoldr' (..) + , HFoldl' (..) + , HTuple' (..) + , Apply (..) + , HZipList + , hZipList + , HFoldr + , hFoldr + , HFoldl + , hFoldl + , HReverse (..) + ) +where + +import Haskus.Utils.Tuple +import Haskus.Utils.Types +import Haskus.Utils.Types.List + +-- | Heterogeneous list +data family HList (l :: [*]) +data instance HList '[] = HNil +data instance HList (x ': xs) = x `HCons` HList xs + +infixr 2 `HCons` + +deriving instance Eq (HList '[]) +deriving instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs)) + +deriving instance Ord (HList '[]) +deriving instance (Ord x, Ord (HList xs)) => Ord (HList (x ': xs)) + + +instance Show (HList '[]) where + show _ = "H[]" + +instance (Show e, Show (HList l)) => Show (HList (e ': l)) where + show (HCons x l) = let 'H':'[':s = show l + in "H[" ++ show x ++ + (if s == "]" then s else "," ++ s) + +-- | Head +hHead :: HList (e ': l) -> e +hHead (HCons x _) = x + +-- | Tail +hTail :: HList (e ': l) -> HList l +hTail (HCons _ l) = l + +-- | Length +hLength :: forall xs. (KnownNat (Length xs)) => HList xs -> Word +hLength _ = natValue' @(Length xs) + +class HAppendList l1 l2 where + hAppend :: HList l1 -> HList l2 -> HList (Concat l1 l2) + +instance HAppendList '[] l2 where + hAppend HNil l = l + +instance HAppendList l l' => HAppendList (x ': l) l' where + hAppend (HCons x l) l' = HCons x (hAppend l l') + + +-- | Apply the function identified by the data type f from type a to type b. +class Apply f a b where + apply :: f -> a -> b + +-------------------------------------- +-- Folding +-------------------------------------- + +class HFoldr f v (l :: [*]) r where + hFoldr :: f -> v -> HList l -> r + +instance (v ~ v') => HFoldr f v '[] v' where + hFoldr _ v _ = v + +instance + ( Apply f (e, r) r' + , HFoldr f v l r + ) => HFoldr f v (e ': l) r' + where + hFoldr f v (HCons x l) = apply f (x, hFoldr f v l :: r) + + +-- | Like HFoldr but only use types, not values! +-- +-- It allows us to foldr over a list of types, without any associated hlist of +-- values. +class HFoldr' f v (l :: [*]) r where + hFoldr' :: f -> v -> HList l -> r + +instance (v ~ v') => HFoldr' f v '[] v' where + hFoldr' _ v _ = v + +instance + ( Apply f (e, r) r' + , HFoldr' f v l r + ) => HFoldr' f v (e ': l) r' + where + -- compared to hFoldr, we pass undefined values instead of the values + -- supposedly in the list (we don't have a real list associated to HList l) + hFoldr' f v _ = apply f (undefined :: e, hFoldr' f v (undefined :: HList l) :: r) + +class HFoldl f (z :: *) xs (r :: *) where + hFoldl :: f -> z -> HList xs -> r + +instance forall f z z' r x zx xs. + ( zx ~ (z,x) + , Apply f zx z' + , HFoldl f z' xs r + ) => HFoldl f z (x ': xs) r + where + hFoldl f z (x `HCons` xs) = hFoldl f (apply f (z,x) :: z') xs + +instance (z ~ z') => HFoldl f z '[] z' where + hFoldl _ z _ = z + +-- | Like HFoldl but only use types, not values! +-- +-- It allows us to foldr over a list of types, without any associated hlist of +-- values. +class HFoldl' f (z :: *) xs (r :: *) where + hFoldl' :: f -> z -> HList xs -> r + +instance forall f z z' r x zx xs. + ( zx ~ (z,x) + , Apply f zx z' + , HFoldl' f z' xs r + ) => HFoldl' f z (x ': xs) r + where + hFoldl' f z (_ `HCons` xs) = hFoldl' f (apply f (z,(undefined :: x)) :: z') xs + +instance (z ~ z') => HFoldl' f z '[] z' where + hFoldl' _ z _ = z + + + +class HZipList x y l | x y -> l, l -> x y where + hZipList :: HList x -> HList y -> HList l + hUnzipList :: HList l -> (HList x, HList y) + +instance HZipList '[] '[] '[] where + hZipList _ _ = HNil + hUnzipList _ = (HNil, HNil) + +instance ((x,y)~z, HZipList xs ys zs) => HZipList (x ': xs) (y ': ys) (z ': zs) where + hZipList (HCons x xs) (HCons y ys) = (x,y) `HCons` hZipList xs ys + hUnzipList (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzipList zs in (x `HCons` xs, y `HCons` ys) + + +class HRevApp l1 l2 l3 | l1 l2 -> l3 where + hRevApp :: HList l1 -> HList l2 -> HList l3 + +instance HRevApp '[] l2 l2 where + hRevApp _ l = l + +instance HRevApp l (x ': l') z => HRevApp (x ': l) l' z where + hRevApp (HCons x l) l' = hRevApp l (HCons x l') + + + +class HReverse xs sx | xs -> sx, sx -> xs where + hReverse :: HList xs -> HList sx + +instance + ( HRevApp xs '[] sx + , HRevApp sx '[] xs + ) => HReverse xs sx + where + hReverse l = hRevApp l HNil + + +-------------------------------------- +-- Tuple convertion +-------------------------------------- + +-- * Conversion to and from tuples + +-- | Convert between hlists and tuples +class HTuple' v t | v -> t, t -> v where + -- | Convert an heterogeneous list into a tuple + hToTuple' :: HList v -> t + + -- | Convert a tuple into an heterogeneous list + hFromTuple' :: t -> HList v + + +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,b] (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,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,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,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,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,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,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,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 diff --git a/src/lib/Haskus/Utils/List.hs b/src/lib/Haskus/Utils/List.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/List.hs @@ -0,0 +1,16 @@ +module Haskus.Utils.List + ( checkLength + , module Data.List + , module Data.List.Extra + ) +where + +import Data.List +import Data.List.Extra + +-- | 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 diff --git a/src/lib/Haskus/Utils/Map.hs b/src/lib/Haskus/Utils/Map.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Map.hs @@ -0,0 +1,6 @@ +module Haskus.Utils.Map + ( module Data.Map + ) +where + +import Data.Map diff --git a/src/lib/Haskus/Utils/Map/Strict.hs b/src/lib/Haskus/Utils/Map/Strict.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Map/Strict.hs @@ -0,0 +1,7 @@ +module Haskus.Utils.Map.Strict + ( module Data.Map.Strict + ) +where + +import Data.Map.Strict + diff --git a/src/lib/Haskus/Utils/Maybe.hs b/src/lib/Haskus/Utils/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Maybe.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Utils for Maybe data type +module Haskus.Utils.Maybe + ( onNothing + , onNothingM + , fromMaybeM + , headMaybe + , module Data.Maybe + ) +where + +import Data.Maybe + +-- | Flipped `fromMaybe` +onNothing :: Maybe a -> a -> a +onNothing = flip fromMaybe + +-- | Flipped `fromMaybeM` +onNothingM :: Monad m => m (Maybe a) -> m a -> m a +onNothingM = flip fromMaybeM + +-- | fromMaybe in a Monad +fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a +fromMaybeM v f = f >>= \case + Nothing -> v + Just x -> return x + +-- | Get the head of the list if the latter is not empty +headMaybe :: [a] -> Maybe a +headMaybe [] = Nothing +headMaybe (x:_) = Just x diff --git a/src/lib/Haskus/Utils/Monad.hs b/src/lib/Haskus/Utils/Monad.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Monad.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Utils for Monads +module Haskus.Utils.Monad + ( MonadInIO (..) + , module Control.Monad + , module Control.Monad.IO.Class + , module Control.Monad.Extra + , module Control.Monad.Trans.Class + ) +where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad +import Control.Monad.Extra +import Control.Monad.State + +class MonadIO m => MonadInIO m where + -- | Lift with*-like functions into IO (alloca, etc.) + liftWith :: (forall c. (a -> IO c) -> IO c) -> (a -> m b) -> m b + + -- | Lift with*-like functions into IO (alloca, etc.) + liftWith2 :: (forall c. (a -> b -> IO c) -> IO c) -> (a -> b -> m e) -> m e + +instance MonadInIO IO where + {-# INLINE liftWith #-} + liftWith = id + + {-# INLINE liftWith2 #-} + liftWith2 = id + +instance MonadInIO m => MonadInIO (StateT s m) where + {-# INLINE liftWith #-} + liftWith wth f = + StateT $ \s -> do + liftWith wth (\a -> runStateT (f a) s) + + {-# INLINE 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 new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Tuple.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Tuple helpers +module Haskus.Utils.Tuple + ( uncurry3 + , uncurry4 + , take4 + , fromTuple4 + , module Data.Tuple + , Single (..) + , TupleToList + , ListToTuple + , ExtractTuple (..) + , TupleHead (..) + , TupleTail (..) + , TupleCons (..) + , ReorderTuple (..) + ) +where + +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 + +-- | 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 + + +-- | Take specialised for quadruple +take4 :: [a] -> (a,a,a,a) +{-# INLINE 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 #-} +fromTuple4 (a,b,c,d) = [a,b,c,d] + +-- | Singleton type +newtype Single a = Single a deriving (Show,Eq) + + +type family TupleToList t 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 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 + -- | Extract a tuple value by type-level index + tupleN :: t -> x + +instance ExtractTuple 0 (Single t) t where + {-# INLINE tupleN #-} + tupleN (Single t) = t + +instance ExtractTuple 0 (e0, e1) e0 where + {-# INLINE tupleN #-} + tupleN (t,_) = t + +instance ExtractTuple 1 (e0, e1) e1 where + {-# INLINE tupleN #-} + tupleN (_,t) = t + +instance ExtractTuple 0 (e0, e1, e2) e0 where + {-# INLINE tupleN #-} + tupleN (t,_,_) = t + +instance ExtractTuple 1 (e0, e1, e2) e1 where + {-# INLINE tupleN #-} + tupleN (_,t,_) = t + +instance ExtractTuple 2 (e0, e1, e2) e2 where + {-# INLINE tupleN #-} + tupleN (_,_,t) = t + +instance ExtractTuple 0 (e0, e1, e2, e3) e0 where + {-# INLINE tupleN #-} + tupleN (t,_,_,_) = t + +instance ExtractTuple 1 (e0, e1, e2, e3) e1 where + {-# INLINE tupleN #-} + tupleN (_,t,_,_) = t + +instance ExtractTuple 2 (e0, e1, e2, e3) e2 where + {-# INLINE tupleN #-} + tupleN (_,_,t,_) = t + +instance ExtractTuple 3 (e0, e1, e2, e3) e3 where + {-# INLINE tupleN #-} + tupleN (_,_,_,t) = t + + +instance ExtractTuple 0 (e0, e1, e2, e3, e4) e0 where + {-# INLINE tupleN #-} + tupleN (t,_,_,_,_) = t + +instance ExtractTuple 1 (e0, e1, e2, e3, e4) e1 where + {-# INLINE tupleN #-} + tupleN (_,t,_,_,_) = t + +instance ExtractTuple 2 (e0, e1, e2, e3, e4) e2 where + {-# INLINE tupleN #-} + tupleN (_,_,t,_,_) = t + +instance ExtractTuple 3 (e0, e1, e2, e3, e4) e3 where + {-# INLINE tupleN #-} + tupleN (_,_,_,t,_) = t + +instance ExtractTuple 4 (e0, e1, e2, e3, e4) e4 where + {-# INLINE tupleN #-} + tupleN (_,_,_,_,t) = t + + +instance ExtractTuple 0 (e0, e1, e2, e3, e4, e5) e0 where + {-# INLINE tupleN #-} + tupleN (t,_,_,_,_,_) = t + +instance ExtractTuple 1 (e0, e1, e2, e3, e4, e5) e1 where + {-# INLINE tupleN #-} + tupleN (_,t,_,_,_,_) = t + +instance ExtractTuple 2 (e0, e1, e2, e3, e4, e5) e2 where + {-# INLINE tupleN #-} + tupleN (_,_,t,_,_,_) = t + +instance ExtractTuple 3 (e0, e1, e2, e3, e4, e5) e3 where + {-# INLINE tupleN #-} + tupleN (_,_,_,t,_,_) = t + +instance ExtractTuple 4 (e0, e1, e2, e3, e4, e5) e4 where + {-# INLINE tupleN #-} + tupleN (_,_,_,_,t,_) = t + +instance ExtractTuple 5 (e0, e1, e2, e3, e4, e5) e5 where + {-# INLINE tupleN #-} + tupleN (_,_,_,_,_,t) = t + + +instance ExtractTuple 0 (e0, e1, e2, e3, e4, e5, e6) e0 where + {-# INLINE tupleN #-} + tupleN (t,_,_,_,_,_,_) = t + +instance ExtractTuple 1 (e0, e1, e2, e3, e4, e5, e6) e1 where + {-# INLINE tupleN #-} + tupleN (_,t,_,_,_,_,_) = t + +instance ExtractTuple 2 (e0, e1, e2, e3, e4, e5, e6) e2 where + {-# INLINE tupleN #-} + tupleN (_,_,t,_,_,_,_) = t + +instance ExtractTuple 3 (e0, e1, e2, e3, e4, e5, e6) e3 where + {-# INLINE tupleN #-} + tupleN (_,_,_,t,_,_,_) = t + +instance ExtractTuple 4 (e0, e1, e2, e3, e4, e5, e6) e4 where + {-# INLINE tupleN #-} + tupleN (_,_,_,_,t,_,_) = t + +instance ExtractTuple 5 (e0, e1, e2, e3, e4, e5, e6) e5 where + {-# INLINE tupleN #-} + tupleN (_,_,_,_,_,t,_) = t + +instance ExtractTuple 6 (e0, e1, e2, e3, e4, e5, e6) e6 where + {-# INLINE tupleN #-} + tupleN (_,_,_,_,_,_,t) = t + + +instance ExtractTuple 0 (e0, e1, e2, e3, e4, e5, e6, e7) e0 where + {-# INLINE tupleN #-} + tupleN (t,_,_,_,_,_,_,_) = t + +instance ExtractTuple 1 (e0, e1, e2, e3, e4, e5, e6, e7) e1 where + {-# INLINE tupleN #-} + tupleN (_,t,_,_,_,_,_,_) = t + +instance ExtractTuple 2 (e0, e1, e2, e3, e4, e5, e6, e7) e2 where + {-# INLINE tupleN #-} + tupleN (_,_,t,_,_,_,_,_) = t + +instance ExtractTuple 3 (e0, e1, e2, e3, e4, e5, e6, e7) e3 where + {-# INLINE tupleN #-} + tupleN (_,_,_,t,_,_,_,_) = t + +instance ExtractTuple 4 (e0, e1, e2, e3, e4, e5, e6, e7) e4 where + {-# INLINE tupleN #-} + tupleN (_,_,_,_,t,_,_,_) = t + +instance ExtractTuple 5 (e0, e1, e2, e3, e4, e5, e6, e7) e5 where + {-# INLINE tupleN #-} + tupleN (_,_,_,_,_,t,_,_) = t + +instance ExtractTuple 6 (e0, e1, e2, e3, e4, e5, e6, e7) e6 where + {-# INLINE tupleN #-} + tupleN (_,_,_,_,_,_,t,_) = t + +instance ExtractTuple 7 (e0, e1, e2, e3, e4, e5, e6, e7) e7 where + {-# INLINE 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 + + +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,c) (b,c) where + {-# INLINE tupleTail #-} + tupleTail (_,b,c) = (b,c) + +instance TupleTail (a,b,c,d) (b,c,d) where + {-# INLINE tupleTail #-} + tupleTail (_,b,c,d) = (b,c,d) + +instance TupleTail (a,b,c,d,e) (b,c,d,e) where + {-# INLINE 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 #-} + tupleTail (_,b,c,d,e,f) = (b,c,d,e,f) + + + +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 (b,c) (a,b,c) where + {-# INLINE tupleCons #-} + tupleCons a (b,c) = (a,b,c) + +instance TupleCons a (b,c,d) (a,b,c,d) where + {-# INLINE 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 #-} + 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 #-} + tupleCons a (b,c,d,e,f) = (a,b,c,d,e,f) + + +-- | Reorder tuple elements +class ReorderTuple t1 t2 where + -- | Reorder tuple elements + tupleReorder :: t1 -> t2 + + +instance ReorderTuple (Single a) (Single a) where + {-# INLINE tupleReorder #-} + tupleReorder = id + +instance ReorderTuple (a,b) (a,b) where + {-# INLINE tupleReorder #-} + tupleReorder = id + +instance ReorderTuple (a,b,c) (a,b,c) where + {-# INLINE tupleReorder #-} + tupleReorder = id + +instance ReorderTuple (a,b,c,d) (a,b,c,d) where + {-# INLINE tupleReorder #-} + tupleReorder = id + +instance ReorderTuple (a,b,c,d,e) (a,b,c,d,e) where + {-# INLINE tupleReorder #-} + tupleReorder = id + +instance ReorderTuple (a,b,c,d,e,f) (a,b,c,d,e,f) where + {-# INLINE tupleReorder #-} + tupleReorder = id + +instance ReorderTuple (a,b,c,d,e,f,g) (a,b,c,d,e,f,g) where + {-# INLINE tupleReorder #-} + tupleReorder = id + +instance ReorderTuple (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g,h) where + {-# INLINE 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 #-} + 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 #-} + tupleReorder = id + + +instance ReorderTuple (a,b) (b,a) where + {-# INLINE tupleReorder #-} + tupleReorder (a,b) = (b,a) + +instance ReorderTuple (a,b,c) (a,c,b) where + {-# INLINE tupleReorder #-} + tupleReorder (a,b,c) = (a,c,b) + +instance ReorderTuple (a,b,c) (b,a,c) where + {-# INLINE tupleReorder #-} + tupleReorder (a,b,c) = (b,a,c) + +instance ReorderTuple (a,b,c) (b,c,a) where + {-# INLINE tupleReorder #-} + tupleReorder (a,b,c) = (b,c,a) + +instance ReorderTuple (a,b,c) (c,a,b) where + {-# INLINE tupleReorder #-} + tupleReorder (a,b,c) = (c,a,b) + +instance ReorderTuple (a,b,c) (c,b,a) where + {-# INLINE 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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 #-} + 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)