packages feed

tuple-ops (empty) → 0.0.0.0

raw patch · 5 files changed

+378/−0 lines, 5 filesdep +base

Dependencies added: base

Files

+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License
+
+Copyright (c) 2018, Jiasen Wu
+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 the copyright holder nor the names of its
+  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 HOLDER OR CONTRIBUTORS 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.
+ src/Data/Tuple/Ops.hs view
@@ -0,0 +1,36 @@+------------------------------------------------------------
+-- |
+-- Module      :  Data.Tuple.Ops
+-- Description :  various operations on n-ary tuples via GHC.Generics
+-- Copyright   :  (c) 2018 Jiasen Wu
+-- License     :  BSD-style (see the file LICENSE)
+-- Maintainer  :  Jiasen Wu <jiasenwu@hotmail.com>
+-- Stability   :  experimental
+-- Portability :  portable
+--
+--
+-- This module exports various operations on n-ary tuples
+------------------------------------------------------------
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module Data.Tuple.Ops(
+    module Data.Tuple.Ops.Uncons
+) where
+
+import GHC.Generics
+import Data.Tuple.Ops.Uncons 
+
+deriving instance Generic Int
+deriving instance Generic Word
+deriving instance Generic Char
+deriving instance Generic Float
+deriving instance Generic Double
+deriving instance Generic (a,b,c,d,e,f,g,h)
+deriving instance Generic (a,b,c,d,e,f,g,h,i)
+deriving instance Generic (a,b,c,d,e,f,g,h,i,j)
+deriving instance Generic (a,b,c,d,e,f,g,h,i,j,k)
+deriving instance Generic (a,b,c,d,e,f,g,h,i,j,k,l)
+deriving instance Generic (a,b,c,d,e,f,g,h,i,j,k,l,m)
+deriving instance Generic (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
+deriving instance Generic (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)
+deriving instance Generic (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)
+ src/Data/Tuple/Ops/Internal.hs view
@@ -0,0 +1,157 @@+------------------------------------------------------------
+-- |
+-- Module      :  Data.Tuple.Ops.Internal
+-- Description :  various operations on n-ary tuples via GHC.Generics
+-- Copyright   :  (c) 2018 Jiasen Wu
+-- License     :  BSD-style (see the file LICENSE)
+-- Maintainer  :  Jiasen Wu <jiasenwu@hotmail.com>
+-- Stability   :  experimental
+-- Portability :  portable
+--
+--
+-- This module defins operations to manipulate the generic 
+-- representation of tuple.
+------------------------------------------------------------
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Data.Tuple.Ops.Internal where
+
+import qualified GHC.Generics as G
+import GHC.Generics (Generic(..), (:*:)(..), (:+:)(..), Rec0, C1, D1, S1, M1(..), U1, K1(..))
+import GHC.TypeLits
+import Data.Proxy
+import qualified Prelude as P 
+import Prelude (Maybe(..), Int, Word, Char, Float, Double, Bool(..), ($))
+
+-- | a sentinial datatype that represents a empty product
+data End a = End
+
+-- | Representation of tuple are shaped in a balanced tree. 
+-- 'L' transforms the tree into a line, for further manipulation.
+class Linearize (t :: * -> *) (b :: * -> *) where
+  type L t b :: * -> *
+  linearize :: t x -> b x -> L t b x
+
+-- | base case 1. cons field with end
+instance Linearize (S1 MetaS (Rec0 t)) End where
+    type L (S1 MetaS (Rec0 t)) End = (S1 MetaS (Rec0 t))
+    linearize a End = a
+
+-- note that it is not possible to combine base case 2 and 3, which results in
+-- a ambiguous instantiation with base case 1
+--
+-- | base case 2. cons field1 with field2 
+instance Linearize (S1 MetaS (Rec0 t)) (S1 MetaS (Rec0 b)) where
+    type L (S1 MetaS (Rec0 t)) (S1 MetaS (Rec0 b)) = S1 MetaS (Rec0 t) :*: S1 MetaS (Rec0 b)
+    linearize a b = a :*: b
+
+-- | base case 3. cons field1 with a product
+instance Linearize (S1 MetaS (Rec0 t)) (b :*: c) where
+    type L (S1 MetaS (Rec0 t)) (b :*: c) = S1 MetaS (Rec0 t) :*: b :*: c
+    linearize a b = a :*: b
+
+-- | inductive case. preppend a product with what ever
+instance (Linearize v b, Linearize u (L v b)) => Linearize (u :*: v) b where
+    type L (u :*: v) b = L u (L v b)
+    linearize (a :*: b) c = linearize a (linearize b c)
+
+-- | calculate the number of fields of a product
+-- note: undefined on non-product rep
+type family Length a :: Nat where
+    Length (S1 MetaS (Rec0 t)) = 1
+    Length (a :*: b) = Length a + Length b
+-- | calculate the number of fields of a product
+length :: a x -> Proxy (Length a)
+length _ = Proxy
+
+-- | calculate the half
+type family Half (a :: Nat) :: Nat where
+    Half 1 = 0
+    Half 2 = 1
+    Half n = Half (n - 2) + 1
+-- | calculate the half
+half :: KnownNat n => Proxy n -> Proxy (Half n)
+half _ = Proxy
+
+-- | Positive natural number in type level
+-- We rely on the SNat to define Take and Drop
+data SNat = One | Succ SNat
+-- | transform the GHC's typelit into SNat
+type family ToSNat (a :: Nat) :: SNat where
+    ToSNat 1 = One
+    ToSNat n = Succ (ToSNat (n - 1))
+-- | transform the GHC's typelit into SNat
+tosnat :: KnownNat n => Proxy n -> Proxy (ToSNat n)
+tosnat _ = Proxy
+
+-- | take the first n elements from a product
+class Take (n :: SNat) (a :: * -> *) where
+    type T n a :: * -> *
+    take :: Proxy n -> a x -> T n a x
+
+-- | base case 1. take one out of singleton
+instance Take One (S1 MetaS (Rec0 t)) where
+    type T One (S1 MetaS (Rec0 t)) = S1 MetaS (Rec0 t)
+    take _ a = a
+
+-- | base case 2. take one out of a product
+instance Take One (a :*: b) where
+    type T One (a :*: b) = a
+    take _ (a :*: _) = a
+
+-- | inductive case. take (n+1) elements
+instance Take n b => Take (Succ n) (a :*: b) where
+    type T (Succ n) (a :*: b) = a :*: T n b
+    take (_ :: Proxy (Succ n)) (a :*: b) = a :*: take (Proxy :: Proxy n) b
+
+-- | drop the first n elements from a product
+class Drop (n :: SNat) (a :: * -> *) where
+    type D n a :: * -> *
+    drop :: Proxy n -> a x -> D n a x
+
+-- | base case 1. drop one from product
+instance Drop One (a :*: b) where
+    type D One (a :*: b) = b
+    drop _ (_ :*: b) = b
+
+-- | inductive case. drop (n+1) elements
+instance Drop n b => Drop (Succ n) (a :*: b) where
+    type D (Succ n) (a :*: b) = D n b
+    drop (_ :: Proxy (Succ n)) (a :*: b) = drop (Proxy :: Proxy n) b
+
+-- | 'Normalize' converts a linear product back into a balanced tree.
+class Normalize (a :: * -> *) where
+    type N a :: * -> * 
+    normalize :: a x -> N a x
+
+-- | base case 1. singleton
+instance Normalize (S1 MetaS (Rec0 t)) where
+    type N (S1 MetaS (Rec0 t)) = S1 MetaS (Rec0 t)
+    normalize a = a
+
+-- | inductive case. product
+instance (KnownNat (Length a + Length b),
+          KnownNat (Half (Length a + Length b)),
+          Take (ToSNat (Half (Length a + Length b))) (a :*: b),
+          Drop (ToSNat (Half (Length a + Length b))) (a :*: b),
+          Normalize ((T (ToSNat (Half (Length a + Length b))) (a :*: b))), 
+          Normalize ((D (ToSNat (Half (Length a + Length b))) (a :*: b)))) 
+    => Normalize (a :*: b) where
+    type N (a :*: b) = N (T (ToSNat (Half (Length a + Length b))) (a :*: b)) :*: 
+                       N (D (ToSNat (Half (Length a + Length b))) (a :*: b))
+    normalize v = let n1 = length v :: Proxy (Length a + Length b)
+                      n2 = tosnat $ half n1
+                  in normalize (take n2 v) :*: normalize (drop n2 v)
+
+type MetaS = 'G.MetaSel 'Nothing 'G.NoSourceUnpackedness 'G.NoSourceStrictness 'G.DecidedLazy
+-- | utility type function to trim the Rec0 
+type family UnRec0 t where
+    UnRec0 (Rec0 t) = t
+-- | utility type function to trim the S1
+type family UnS1 t where
+    UnS1 (S1 _ t) = t
+-- | utility type function to trim the D1
+type family UnD1 t where
+    UnD1 (D1 _ t) = t
+ src/Data/Tuple/Ops/Uncons.hs view
@@ -0,0 +1,130 @@+------------------------------------------------------------
+-- |
+-- Module      :  Data.Tuple.Ops.Uncons
+-- Description :  various operations on n-ary tuples via GHC.Generics
+-- Copyright   :  (c) 2018 Jiasen Wu
+-- License     :  BSD-style (see the file LICENSE)
+-- Maintainer  :  Jiasen Wu <jiasenwu@hotmail.com>
+-- Stability   :  experimental
+-- Portability :  portable
+--
+--
+-- This module define 'uncons'. Examples are given below:
+--
+-- >>> uncons (1::Int)
+-- (1,())
+--
+-- >>> uncons (1::Int,'a')
+-- (1,'a')
+--
+-- >>> uncons (True,'a', "S")
+-- (True,('a',"S"))
+--
+------------------------------------------------------------
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Data.Tuple.Ops.Uncons (uncons, Uncons) where
+
+import qualified GHC.Generics as G
+import GHC.Generics (Generic(..), (:*:)(..), (:+:)(..), Rec0, C1, D1, S1, M1(..), U1, K1(..))
+import GHC.TypeLits
+import Data.Tuple.Ops.Internal
+
+-- | representation of a pair
+type RepOfPair t1 t2 = C1 ('G.MetaCons "(,)" 'G.PrefixI 'False) (S1 MetaS (Rec0 t1) :*: S1 MetaS (Rec0 t2))
+-- | representation of a tuple of arity > 2, in which @/u/@ is of the form @_ :*: _@
+type RepOfTuple c u = C1 ('G.MetaCons c 'G.PrefixI 'False) u 
+
+-- | 'HeadR' is a type function that takes the first element of a tuple
+type family HeadR (f :: * -> *) :: * -> * where
+    HeadR (C1 mc (S1 ms (G.URec a))) = C1 mc (S1 ms (G.URec a))
+    HeadR (a :+: b) = a :+: b
+    HeadR (RepOfPair t1 t2) = UnD1 (Rep t1)
+    HeadR (RepOfTuple tcon (a :*: b :*: c)) = UnD1 (Rep (UnRec0 (UnS1 (T One (L (a :*: b :*: c) End)))))
+-- | 'TailR' is a type function that drops the first element of a tuple
+type family TailR (f :: * -> *) :: * -> * where
+    TailR (C1 mc (S1 ms (G.URec a))) = C1 ('G.MetaCons "()" 'G.PrefixI 'False) U1
+    TailR (a :+: b) = C1 ('G.MetaCons "()" 'G.PrefixI 'False) U1
+    TailR (RepOfPair t1 t2) = UnD1 (Rep t2)
+    TailR (RepOfTuple tcon (a :*: b :*: c)) = RepOfTuple (TupleConPred tcon) (N (D One (L (a :*: b :*: c) End)))
+
+-- | Abstract type class for generic representation of a /uncons/able datatype
+class UnconsR f where
+    unconsR :: f a -> (HeadR f a, TailR f a)
+
+-- | primitive datatype
+-- 'HeadR' is the datatype itself
+-- 'TailR' is ()
+instance UnconsR (C1 mc (S1 ms (G.URec a))) where
+    unconsR a = (a, unM1 (from ()))
+
+-- | sum datatype
+-- 'HeadR' is the datatype itself
+-- 'TailR' is ()
+instance UnconsR (a :+: b) where
+    unconsR a = (a, unM1 (from ()))
+
+-- | pair
+-- 'HeadR' is the first element
+-- 'TailR' is the second element
+instance (Generic t1, Rep t1 ~ D1 mt1 ct1,
+          Generic t2, Rep t2 ~ D1 mt2 ct2)
+    => UnconsR (RepOfPair t1 t2) where
+    unconsR (M1 (a :*: b)) = (unM1 $ from $ unK1 $ unM1 a, unM1 $ from $ unK1 $ unM1 b)
+
+-- | tuple of arity > 2
+-- 'HeadR' is the first element
+-- 'TailR' is the rest all elements
+instance (Linearize c End, Linearize b (L c End), Linearize a (L b (L c End)),
+          L a (L b (L c End)) ~ (S1 MetaS (Rec0 t) :*: w), 
+          Generic t, Rep t ~ D1 hm hc, Normalize w) 
+    => UnconsR (RepOfTuple tcon (a :*: b :*: c)) where
+    unconsR a = case linearize (unM1 a) End of
+                  u :*: v -> (unM1 $ from $ unK1 $ unM1 u, M1 $ normalize v)
+
+-- | calculate the tuple constructor of the size 1 smaller
+-- upto the tupel of arity of 16
+type family TupleConPred (a :: Symbol) where
+    TupleConPred "(,,)" = "(,)"
+    TupleConPred "(,,,)" = "(,,)"
+    TupleConPred "(,,,,)" = "(,,,)"
+    TupleConPred "(,,,,,)" = "(,,,,)"
+    TupleConPred "(,,,,,,)" = "(,,,,,)"
+    TupleConPred "(,,,,,,,)" = "(,,,,,,)"
+    TupleConPred "(,,,,,,,,)" = "(,,,,,,,)"
+    TupleConPred "(,,,,,,,,,)" = "(,,,,,,,,)"
+    TupleConPred "(,,,,,,,,,,)" = "(,,,,,,,,,)"
+    TupleConPred "(,,,,,,,,,,,)" = "(,,,,,,,,,,)"
+    TupleConPred "(,,,,,,,,,,,,)" = "(,,,,,,,,,,,)"
+    TupleConPred "(,,,,,,,,,,,,,)" = "(,,,,,,,,,,,,)"
+    TupleConPred "(,,,,,,,,,,,,,,)" = "(,,,,,,,,,,,,,)"
+    TupleConPred "(,,,,,,,,,,,,,,,)" = "(,,,,,,,,,,,,,,)"
+    TupleConPred "(,,,,,,,,,,,,,,,,)" = "(,,,,,,,,,,,,,,,)"
+
+-- | calculate the result type of 'uncons'
+type family Uncons a where
+    Uncons (a,b) = (a,b)
+    Uncons (a,b,c) = (a, (b,c))
+    Uncons (a,b,c,d) = (a, (b,c,d))
+    Uncons (a,b,c,d,e) = (a, (b,c,d,e))
+    Uncons (a,b,c,d,e,f) = (a, (b,c,d,e,f))
+    Uncons (a,b,c,d,e,f,g) = (a, (b,c,d,e,f,g))
+    Uncons (a,b,c,d,e,f,g,h) = (a, (b,c,d,e,f,g,h))
+    Uncons (a,b,c,d,e,f,g,h,i) = (a, (b,c,d,e,f,g,h,i))
+    Uncons (a,b,c,d,e,f,g,h,i,j) = (a, (b,c,d,e,f,g,h,i,j))
+    Uncons (a,b,c,d,e,f,g,h,i,j,k) = (a, (b,c,d,e,f,g,h,i,j,k))
+    Uncons (a,b,c,d,e,f,g,h,i,j,k,l) = (a, (b,c,d,e,f,g,h,i,j,k,l))
+    Uncons (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))
+    Uncons (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))
+    Uncons (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))
+    Uncons (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))
+    Uncons a = (a, ())
+
+-- | 'uncons' takes primitive, pair, tuple
+-- and produces a pair of its first data and the rest elements.
+uncons :: (Generic a, Rep a ~ D1 ma ra, Uncons a ~ (b, c),
+           Generic b, Rep b ~ D1 mb rb,
+           Generic c, Rep c ~ D1 mc rc,
+           UnconsR ra, HeadR ra ~ rb, TailR ra ~ rc)
+       => a -> Uncons a 
+uncons x = let (a, b) = unconsR $ unM1 $ from x in (to $ M1 a, to $ M1 b)
+ tuple-ops.cabal view
@@ -0,0 +1,26 @@+name:                       tuple-ops
+version:                    0.0.0.0
+category:                   Data
+author:                     Jiasen Wu
+maintainer:                 Jiasen Wu <jiasenwu@hotmail.com>
+homepage:                   https://github.com/pierric/tuple-ops
+synopsis:                   various operations on n-ary tuples via GHC.Generics
+description:                Uncons operation on n-ary tuples
+license:                    BSD3
+license-file:               LICENSE
+build-type:                 Simple
+cabal-version:              >= 1.24
+
+Library
+    hs-source-dirs:         src
+    exposed-modules:        Data.Tuple.Ops
+                          , Data.Tuple.Ops.Uncons
+                          , Data.Tuple.Ops.Internal
+    default-language:       Haskell2010
+    default-extensions:     DataKinds
+                          , TypeOperators
+                          , KindSignatures
+                          , TypeFamilies
+                          , UndecidableInstances
+                          , FlexibleInstances
+    build-depends:          base >= 4.7 && < 5.0