├── Setup.hs ├── src ├── Type │ ├── Family │ │ ├── Monoid.hs │ │ ├── Bool.hs │ │ ├── Constraint.hs │ │ ├── Tuple.hs │ │ ├── Maybe.hs │ │ ├── Either.hs │ │ ├── Nat.hs │ │ └── List.hs │ └── Class │ │ ├── Known.hs │ │ ├── Witness.hs │ │ └── Higher.hs └── Data │ └── Type │ ├── Index │ └── Trans.hs │ ├── Nat │ └── Inequality.hs │ ├── Option.hs │ ├── Subset.hs │ ├── Length.hs │ ├── Boolean.hs │ ├── Fin.hs │ ├── Index.hs │ ├── Sum │ └── Lifted.hs │ ├── Nat.hs │ ├── Product │ ├── Env.hs │ └── Lifted.hs │ ├── Remove.hs │ ├── Difference.hs │ ├── Sum.hs │ ├── Fin │ └── Indexed.hs │ ├── Disjunction.hs │ ├── Conjunction.hs │ ├── Product.hs │ ├── Combinator.hs │ └── Vector.hs ├── LICENSE └── type-combinators.cabal /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/Type/Family/Monoid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Type.Family.Monoid 8 | -- Copyright : Copyright (C) 2015 Kyle Carter 9 | -- License : BSD3 10 | -- 11 | -- Maintainer : Kyle Carter 12 | -- Stability : experimental 13 | -- Portability : RankNTypes 14 | -- 15 | -- Type-level @Monoid@, defined as an open type family. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | module Type.Family.Monoid where 20 | 21 | type family Mempty :: k 22 | type family (a :: k) <> (b :: k) :: k 23 | 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Kyle Carter 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Kyle Carter nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Type/Family/Bool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilyDependencies #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE FunctionalDependencies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE LambdaCase #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE DataKinds #-} 14 | {-# LANGUAGE PolyKinds #-} 15 | {-# LANGUAGE GADTs #-} 16 | ----------------------------------------------------------------------------- 17 | -- | 18 | -- Module : Type.Family.Bool 19 | -- Copyright : Copyright (C) 2015 Kyle Carter 20 | -- License : BSD3 21 | -- 22 | -- Maintainer : Kyle Carter 23 | -- Stability : experimental 24 | -- Portability : RankNTypes 25 | -- 26 | -- Convenient type families for working with type-level @Bool@s. 27 | ---------------------------------------------------------------------------- 28 | 29 | module Type.Family.Bool 30 | ( module Type.Family.Bool 31 | , module Exports 32 | ) where 33 | 34 | import Type.Family.Constraint 35 | import Type.Class.Witness as Exports (type (==)) 36 | import Data.Type.Bool as Exports (type If, type Not, type (||), type (&&)) 37 | 38 | type family BoolC (b :: Bool) = (c :: Constraint) | c -> b where 39 | BoolC True = ØC 40 | BoolC False = Fail 41 | 42 | type a ==> b = Not a || b 43 | infixr 1 ==> 44 | 45 | type a <==> b = a == b 46 | infixr 1 <==> 47 | 48 | type a ^^ b = (a || b) && Not (a && b) 49 | infixr 4 ^^ 50 | 51 | -------------------------------------------------------------------------------- /src/Type/Family/Constraint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE UndecidableSuperClasses #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE GADTs #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Type.Family.Constraint 18 | -- Copyright : Copyright (C) 2015 Kyle Carter 19 | -- License : BSD3 20 | -- 21 | -- Maintainer : Kyle Carter 22 | -- Stability : experimental 23 | -- Portability : RankNTypes 24 | -- 25 | -- Reexports the kind 'GHC.Exts.Constraint', as well as some 26 | -- conveniences for working with 'Constraint's. 27 | ---------------------------------------------------------------------------- 28 | 29 | module Type.Family.Constraint 30 | ( module Type.Family.Constraint 31 | , Constraint 32 | ) where 33 | 34 | import GHC.Exts (Constraint) 35 | 36 | -- | The empty 'Constraint'. 37 | type ØC = (() :: Constraint) 38 | type Fail = (True ~ False) 39 | 40 | class IffC b t f => Iff (b :: Bool) (t :: Constraint) (f :: Constraint) where 41 | type IffC b t f :: Constraint 42 | instance t => Iff True t f where 43 | type IffC True t f = t 44 | instance f => Iff False t f where 45 | type IffC False t f = f 46 | 47 | class d (c a) => Comp (d :: l -> Constraint) (c :: k -> l) (a :: k) 48 | instance d (c a) => Comp d c a 49 | 50 | -------------------------------------------------------------------------------- /type-combinators.cabal: -------------------------------------------------------------------------------- 1 | name: type-combinators 2 | version: 0.2.4.3 3 | category: Data 4 | synopsis: A collection of data types for type-level programming 5 | cabal-version: >=1.10 6 | build-type: Simple 7 | license: BSD3 8 | license-file: LICENSE 9 | maintainer: kylcarte@gmail.com 10 | copyright: (c) 2015 Kyle Carter, all rights reserved 11 | author: Kyle Carter 12 | homepage: https://github.com/kylcarte/type-combinators 13 | 14 | Source-Repository head 15 | type: git 16 | location: git://github.com/kylcarte/type-combinators.git 17 | 18 | library 19 | exposed-modules: 20 | -- Data.Type.Polynomial 21 | Data.Type.Boolean 22 | Data.Type.Combinator 23 | Data.Type.Conjunction 24 | Data.Type.Difference 25 | Data.Type.Disjunction 26 | Data.Type.Fin 27 | Data.Type.Fin.Indexed 28 | Data.Type.Index 29 | Data.Type.Index.Trans 30 | Data.Type.Length 31 | Data.Type.Nat 32 | Data.Type.Nat.Inequality 33 | Data.Type.Option 34 | Data.Type.Product 35 | Data.Type.Product.Env 36 | Data.Type.Product.Lifted 37 | Data.Type.Remove 38 | Data.Type.Subset 39 | Data.Type.Sum 40 | Data.Type.Sum.Lifted 41 | -- Data.Type.Sym 42 | -- Data.Type.Quantifier 43 | Data.Type.Vector 44 | Type.Class.Higher 45 | Type.Class.Known 46 | Type.Class.Witness 47 | Type.Family.Bool 48 | Type.Family.Constraint 49 | Type.Family.Either 50 | Type.Family.List 51 | Type.Family.Maybe 52 | Type.Family.Monoid 53 | Type.Family.Nat 54 | -- Type.Family.Symbol 55 | Type.Family.Tuple 56 | build-depends: 57 | base >=4.11 && <5.0 58 | default-language: Haskell2010 59 | hs-source-dirs: src 60 | ghc-options: -Wall -fno-warn-unticked-promoted-constructors 61 | 62 | -------------------------------------------------------------------------------- /src/Type/Class/Known.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableSuperClasses #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE GADTs #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Type.Class.Known 18 | -- Copyright : Copyright (C) 2015 Kyle Carter 19 | -- License : BSD3 20 | -- 21 | -- Maintainer : Kyle Carter 22 | -- Stability : experimental 23 | -- Portability : RankNTypes 24 | -- 25 | -- The 'Known' class, among others in this library, use an associated 26 | -- 'Constraint' to maintain a bidirectional chain of inference. 27 | -- 28 | -- For instance, given evidence of @Known Nat n@, if @n@ later gets refined 29 | -- to @n'@, we can correctly infer @Known Nat n'@, as per the type instance 30 | -- defined for @KnownC Nat (S n')@. 31 | ---------------------------------------------------------------------------- 32 | 33 | module Type.Class.Known where 34 | 35 | import Type.Family.Constraint 36 | 37 | import Data.Proxy 38 | import Data.Type.Equality 39 | 40 | -- | Each instance of 'Known' provides a canonical construction 41 | -- of a type at a particular index. 42 | -- 43 | -- Useful for working with singleton-esque GADTs. 44 | class KnownC f a => Known (f :: k -> *) (a :: k) where 45 | type KnownC f a :: Constraint 46 | type KnownC (f :: k -> *) (a :: k) = ØC 47 | known :: f a 48 | 49 | instance (a ~ b) => Known ((:~:) a) b where 50 | type KnownC ((:~:) a) b = (a ~ b) 51 | known = Refl 52 | 53 | -- | The 'Proxy' is the canonical constructor for any @'Proxy' a@. 54 | instance Known Proxy a where 55 | known = Proxy 56 | -------------------------------------------------------------------------------- /src/Data/Type/Index/Trans.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE FlexibleContexts #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | {-# LANGUAGE LambdaCase #-} 15 | 16 | module Data.Type.Index.Trans 17 | ( module Data.Type.Index.Trans 18 | , (:~:)(..) 19 | ) where 20 | 21 | import Type.Class.Witness ((:~:)(..)) 22 | import Type.Family.List 23 | import Type.Family.Tuple 24 | 25 | type IxList' = IxList (:~:) 26 | type IxEnv = IxList (IxFirst (:~:)) 27 | 28 | class IxLift (t :: (k -> m -> *) -> l -> m -> *) (x :: l) where 29 | type LiftI t x :: k 30 | ixLift :: i (LiftI t x) y 31 | -> t i x y 32 | 33 | data IxList (i :: k -> l -> *) :: [k] -> l -> * where 34 | IxHead :: !(i a b) 35 | -> IxList i (a :< as) b 36 | IxTail :: !(IxList i as b) 37 | -> IxList i (a :< as) b 38 | 39 | data IxFirst (i :: k -> l -> *) :: (k,m) -> l -> * where 40 | IxFirst :: !(i a b) 41 | -> IxFirst i '(a,c) b 42 | 43 | instance (p ~ '(Fst p,Snd p)) => IxLift IxFirst p where 44 | type LiftI IxFirst p = Fst p 45 | ixLift = IxFirst 46 | 47 | data IxSecond (i :: k -> l -> *) :: (m,k) -> l -> * where 48 | IxSecond :: !(i a b) 49 | -> IxSecond i '(c,a) b 50 | 51 | instance (p ~ '(Fst p,Snd p)) => IxLift IxSecond p where 52 | type LiftI IxSecond p = Snd p 53 | ixLift = IxSecond 54 | 55 | data IxOr (i :: k -> m -> *) (j :: l -> m -> *) :: Either k l -> m -> * where 56 | IxOrL :: !(i a b) 57 | -> IxOr i j (Left a) b 58 | IxOrR :: !(j a b) 59 | -> IxOr i j (Right a) b 60 | 61 | instance IxLift (IxOr i) (Right a) where 62 | type LiftI (IxOr i) (Right a) = a 63 | ixLift = IxOrR 64 | 65 | data IxJust (i :: k -> l -> *) :: Maybe k -> l -> * where 66 | IxJust :: !(i a b) 67 | -> IxJust i (Just a) b 68 | 69 | data IxComp (i :: k -> l -> *) (j :: l -> m -> *) :: k -> m -> * where 70 | IxComp :: !(i a b) 71 | -> !(j b c) 72 | -> IxComp i j a c 73 | 74 | -------------------------------------------------------------------------------- /src/Data/Type/Nat/Inequality.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE FlexibleContexts #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-# LANGUAGE LambdaCase #-} 14 | 15 | module Data.Type.Nat.Inequality where 16 | 17 | import Data.Type.Nat 18 | import Type.Class.Known 19 | import Type.Class.Witness 20 | import Type.Family.Constraint 21 | import Type.Family.Nat 22 | 23 | data NatLT :: N -> N -> * where 24 | LTZ :: NatLT Z (S y) 25 | LTS :: !(NatLT x y) 26 | -> NatLT (S x) (S y) 27 | 28 | data NatEQ :: N -> N -> * where 29 | EQZ :: NatEQ Z Z 30 | EQS :: !(NatEQ x y) 31 | -> NatEQ (S x) (S y) 32 | 33 | data NatGT :: N -> N -> * where 34 | GTZ :: NatGT (S x) Z 35 | GTS :: !(NatGT x y) 36 | -> NatGT (S x) (S y) 37 | 38 | instance (lt ~ (x < y), eq ~ (x == y), gt ~ (x > y), y' ~ Pred y) => Witness ØC (y ~ S y', Known Nat x, lt ~ True, eq ~ False, gt ~ False) (NatLT x y) where 39 | type WitnessC ØC (y ~ S y', Known Nat x, lt ~ True, eq ~ False, gt ~ False) (NatLT x y) = (lt ~ (x < y), eq ~ (x == y), gt ~ (x > y), y' ~ Pred y) 40 | (\\) r = \case 41 | LTZ -> r 42 | LTS l -> r \\ l 43 | 44 | instance (lt ~ (x < y), eq ~ (x == y), gt ~ (x > y)) => Witness ØC (x ~ y, Known Nat x, lt ~ False, eq ~ True, gt ~ False) (NatEQ x y) where 45 | type WitnessC ØC (x ~ y, Known Nat x, lt ~ False, eq ~ True, gt ~ False) (NatEQ x y) = (lt ~ (x < y), eq ~ (x == y), gt ~ (x > y)) 46 | (\\) r = \case 47 | EQZ -> r 48 | EQS l -> r \\ l 49 | 50 | instance (lt ~ (x < y), eq ~ (x == y), gt ~ (x > y), x' ~ Pred x) => Witness ØC (x ~ S x', Known Nat y, lt ~ False, eq ~ False, gt ~ True) (NatGT x y) where 51 | type WitnessC ØC (x ~ S x', Known Nat y, lt ~ False, eq ~ False, gt ~ True) (NatGT x y) = (lt ~ (x < y), eq ~ (x == y), gt ~ (x > y), x' ~ Pred x) 52 | (\\) r = \case 53 | GTZ -> r 54 | GTS l -> r \\ l 55 | 56 | natCompare :: Nat x -> Nat y -> Either (NatLT x y) (Either (NatEQ x y) (NatGT x y)) 57 | natCompare = \case 58 | Z_ -> \case 59 | Z_ -> Right $ Left EQZ 60 | S_ _ -> Left LTZ 61 | S_ x -> \case 62 | Z_ -> Right $ Right GTZ 63 | S_ y -> case natCompare x y of 64 | Left lt -> Left $ LTS lt 65 | Right (Left eq) -> Right $ Left $ EQS eq 66 | Right (Right gt) -> Right $ Right $ GTS gt 67 | 68 | -------------------------------------------------------------------------------- /src/Type/Family/Tuple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE GADTs #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Type.Family.Tuple 18 | -- Copyright : Copyright (C) 2015 Kyle Carter 19 | -- License : BSD3 20 | -- 21 | -- Maintainer : Kyle Carter 22 | -- Stability : experimental 23 | -- Portability : RankNTypes 24 | -- 25 | -- Type-level pairs and triples, along with some convenient aliases and type families 26 | -- over them. 27 | -- 28 | ----------------------------------------------------------------------------- 29 | 30 | module Type.Family.Tuple where 31 | 32 | import Type.Family.Monoid 33 | import Type.Class.Witness 34 | 35 | type (#) = '(,) 36 | infixr 6 # 37 | 38 | -- Fst,Snd,Thd et al {{{ 39 | 40 | type family Fst (p :: (k,l)) :: k where 41 | Fst '(a,b) = a 42 | 43 | fstCong :: (p ~ q) :- (Fst p ~ Fst q) 44 | fstCong = Sub Wit 45 | 46 | type family Snd (p :: (k,l)) :: l where 47 | Snd '(a,b) = b 48 | 49 | sndCong :: (p ~ q) :- (Snd p ~ Snd q) 50 | sndCong = Sub Wit 51 | 52 | type family Fst3 (p :: (k,l,m)) :: k where 53 | Fst3 '(a,b,c) = a 54 | 55 | fst3Cong :: (p ~ q) :- (Fst3 p ~ Fst3 q) 56 | fst3Cong = Sub Wit 57 | 58 | type family Snd3 (p :: (k,l,m)) :: l where 59 | Snd3 '(a,b,c) = b 60 | 61 | snd3Cong :: (p ~ q) :- (Snd3 p ~ Snd3 q) 62 | snd3Cong = Sub Wit 63 | 64 | type family Thd3 (p :: (k,l,m)) :: m where 65 | Thd3 '(a,b,c) = c 66 | 67 | thd3Cong :: (p ~ q) :- (Thd3 p ~ Thd3 q) 68 | thd3Cong = Sub Wit 69 | 70 | -- }}} 71 | 72 | -- Map et al {{{ 73 | 74 | type family (f :: k -> l) <$> (a :: (m,k)) :: (m,l) where 75 | f <$> (a#b) = a # f b 76 | infixr 4 <$> 77 | 78 | pairMapCong :: (f ~ g,a ~ b) :- ((f <$> a) ~ (g <$> b)) 79 | pairMapCong = Sub Wit 80 | 81 | type family (f :: (m,k -> l)) <&> (a :: k) :: (m,l) where 82 | (r#f) <&> a = r # f a 83 | infixr 4 <&> 84 | 85 | type family (f :: (m,k -> l)) <*> (a :: (m,k)) :: (m,l) where 86 | (r#f) <*> (s#a) = (r <> s) # f a 87 | infixr 4 <*> 88 | 89 | -- }}} 90 | 91 | -- | A type-level pair is a Monoid over its pairwise components. 92 | type instance Mempty = Mempty # Mempty 93 | type instance (r#a) <> (s#b) = (r <> s) # (a <> b) 94 | 95 | type instance Mempty = '(Mempty,Mempty,Mempty) 96 | type instance '(a,b,c) <> '(d,e,f) = '(a<>d,b<>e,c<>f) 97 | 98 | -------------------------------------------------------------------------------- /src/Data/Type/Option.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE GADTs #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Type.Option 18 | -- Copyright : Copyright (C) 2015 Kyle Carter 19 | -- License : BSD3 20 | -- 21 | -- Maintainer : Kyle Carter 22 | -- Stability : experimental 23 | -- Portability : RankNTypes 24 | -- 25 | -- A type combinator for type-level @Maybe@s, 26 | -- lifting @(f :: k -> *)@ to @(Option f :: Maybe k -> *)@. 27 | -- 28 | ----------------------------------------------------------------------------- 29 | 30 | module Data.Type.Option where 31 | 32 | import Type.Class.Higher 33 | import Type.Class.Known 34 | import Type.Class.Witness 35 | import Type.Family.Maybe 36 | 37 | data Option (f :: k -> *) :: Maybe k -> * where 38 | Nothing_ :: Option f Nothing 39 | Just_ :: !(f a) -> Option f (Just a) 40 | 41 | deriving instance MaybeC (Eq <$> f <$> m) => Eq (Option f m) 42 | deriving instance 43 | ( MaybeC (Eq <$> f <$> m) 44 | , MaybeC (Ord <$> f <$> m) 45 | ) => Ord (Option f m) 46 | deriving instance MaybeC (Show <$> f <$> m) => Show (Option f m) 47 | 48 | -- | Eliminator for @'Option' f@. 49 | option :: (forall a. (m ~ Just a) => f a -> r) -> ((m ~ Nothing) => r) -> Option f m -> r 50 | option j n = \case 51 | Just_ a -> j a 52 | Nothing_ -> n 53 | 54 | -- | We can take a natural transformation of @(forall x. f x -> g x)@ to 55 | -- a natural transformation of @(forall mx. 'Option' f mx -> 'Option' g mx)@. 56 | instance Functor1 Option where 57 | map1 f = \case 58 | Just_ a -> Just_ $ f a 59 | Nothing_ -> Nothing_ 60 | 61 | instance Foldable1 Option where 62 | foldMap1 f = \case 63 | Just_ a -> f a 64 | Nothing_ -> mempty 65 | 66 | instance Traversable1 Option where 67 | traverse1 f = \case 68 | Just_ a -> Just_ <$> f a 69 | Nothing_ -> pure Nothing_ 70 | 71 | instance Known (Option f) Nothing where 72 | known = Nothing_ 73 | 74 | instance Known f a => Known (Option f) (Just a) where 75 | type KnownC (Option f) (Just a) = Known f a 76 | known = Just_ known 77 | 78 | instance (Witness p q (f a), x ~ Just a) => Witness p q (Option f x) where 79 | type WitnessC p q (Option f x) = Witness p q (f (FromJust x)) 80 | (\\) r = \case 81 | Just_ a -> r \\ a 82 | 83 | -------------------------------------------------------------------------------- /src/Data/Type/Subset.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE DataKinds #-} 12 | {-# LANGUAGE PolyKinds #-} 13 | {-# LANGUAGE GADTs #-} 14 | ----------------------------------------------------------------------------- 15 | -- | 16 | -- Module : Data.Type.Subset 17 | -- Copyright : Copyright (C) 2015 Kyle Carter 18 | -- License : BSD3 19 | -- 20 | -- Maintainer : Kyle Carter 21 | -- Stability : experimental 22 | -- Portability : RankNTypes 23 | -- 24 | -- A @singleton@-esque type for representing subsets of a type level list. 25 | -- 26 | ----------------------------------------------------------------------------- 27 | 28 | module Data.Type.Subset 29 | ( module Data.Type.Subset 30 | , module Exports 31 | ) where 32 | 33 | -- import Data.Type.Quantifier 34 | import Type.Class.Higher 35 | import Type.Class.Known 36 | import Type.Class.Witness 37 | import Type.Family.List 38 | import Data.Type.Index 39 | import Data.Type.Length 40 | import Data.Type.Product as Exports (Prod(..)) 41 | import Data.Type.Product (index) 42 | import Data.Type.Sum (Sum(..),prj) 43 | import Control.Applicative ((<|>)) 44 | 45 | type Subset as = Prod (Index as) 46 | 47 | subNil :: Subset Ø as -> (as :~: Ø) 48 | subNil = \case 49 | Ø -> Refl 50 | x :< _ -> ixNil x 51 | 52 | type as ⊆ bs = Every (Elem bs) as 53 | infix 4 ⊆ 54 | 55 | subRefl :: Known Length as 56 | => Subset as as 57 | subRefl = go known 58 | where 59 | go :: Length xs -> Subset xs xs 60 | go = \case 61 | LZ -> Ø 62 | LS l -> IZ :< map1 IS (go l) 63 | 64 | subTrans :: Subset as bs -> Subset bs cs -> Subset as cs 65 | subTrans s = map1 $ subIx s 66 | 67 | subProd :: Subset as bs -> Prod f as -> Prod f bs 68 | subProd = \case 69 | Ø -> pure Ø 70 | x :< s -> (:<) <$> index x <*> subProd s 71 | 72 | subSum :: Subset as bs -> Sum f as -> Maybe (Sum f bs) 73 | subSum = \case 74 | Ø -> pure Nothing 75 | x :< s -> \t -> (InL <$> (prj t \\ x)) 76 | <|> (InR <$> subSum s t) 77 | 78 | subIx :: Subset as bs -> Index bs x -> Index as x 79 | subIx = \case 80 | Ø -> ixNil 81 | x :< s -> \case 82 | IZ -> x 83 | IS y -> subIx s y 84 | 85 | subExt :: Known Length as => (forall x. Index as x -> Index bs x) -> Subset bs as 86 | subExt f = subExtBy f known 87 | 88 | subExtBy :: (forall x. Index as x -> Index bs x) -> Length as -> Subset bs as 89 | subExtBy f = \case 90 | LZ -> Ø 91 | LS l -> f IZ :< subExtBy (f . IS) l 92 | 93 | -------------------------------------------------------------------------------- /src/Data/Type/Length.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE GADTs #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Type.Length 18 | -- Copyright : Copyright (C) 2015 Kyle Carter 19 | -- License : BSD3 20 | -- 21 | -- Maintainer : Kyle Carter 22 | -- Stability : experimental 23 | -- Portability : RankNTypes 24 | -- 25 | -- A @singleton@-esque type for representing lengths of type-level lists, 26 | -- irrespective of the actual types in that list. 27 | -- 28 | ----------------------------------------------------------------------------- 29 | 30 | module Data.Type.Length where 31 | 32 | -- import Data.Type.Quantifier 33 | import Type.Class.Witness 34 | import Type.Class.Higher 35 | import Type.Class.Known 36 | import Type.Family.Constraint 37 | import Type.Family.List 38 | import Type.Family.Nat 39 | import Data.Type.Nat 40 | 41 | data Length :: [k] -> * where 42 | LZ :: Length Ø 43 | LS :: !(Length as) -> Length (a :< as) 44 | 45 | deriving instance Eq (Length as) 46 | deriving instance Ord (Length as) 47 | deriving instance Show (Length as) 48 | 49 | instance Eq1 Length 50 | instance Ord1 Length 51 | instance Show1 Length 52 | 53 | instance Read1 Length where 54 | readsPrec1 d = readParen (d > 10) $ \s0 -> 55 | [ (Some LZ,s1) 56 | | ("LZ",s1) <- lex s0 57 | ] ++ 58 | [ (l >>- Some . LS,s2) 59 | | ("LS",s1) <- lex s0 60 | , (l,s2) <- readsPrec1 11 s1 61 | ] 62 | 63 | instance Known Length Ø where 64 | known = LZ 65 | 66 | instance Known Length as => Known Length (a :< as) where 67 | type KnownC Length (a :< as) = Known Length as 68 | known = LS known 69 | 70 | instance (n ~ Len as) => Witness ØC (Known Nat n, Known Length as) (Length as) where 71 | type WitnessC ØC (Known Nat n, Known Length as) (Length as) = (n ~ Len as) 72 | (\\) r = \case 73 | LZ -> r 74 | LS l -> r \\ l 75 | 76 | {- 77 | natLen :: Nat (Len as) -> Length as 78 | natLen = \case 79 | Z_ -> LZ 80 | S_ n -> _ 81 | -} 82 | 83 | elimLength :: p Ø 84 | -> (forall x xs. Length xs -> p xs -> p (x :< xs)) 85 | -> Length as 86 | -> p as 87 | elimLength z s = \case 88 | LZ -> z 89 | LS l -> s l $ elimLength z s l 90 | 91 | lOdd, lEven :: Length as -> Bool 92 | lOdd = \case 93 | LZ -> False 94 | LS l -> lEven l 95 | lEven = \case 96 | LZ -> True 97 | LS l -> lOdd l 98 | 99 | -------------------------------------------------------------------------------- /src/Type/Family/Maybe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE KindSignatures #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE GADTs #-} 13 | ----------------------------------------------------------------------------- 14 | -- | 15 | -- Module : Type.Family.Maybe 16 | -- Copyright : Copyright (C) 2015 Kyle Carter 17 | -- License : BSD3 18 | -- 19 | -- Maintainer : Kyle Carter 20 | -- Stability : experimental 21 | -- Portability : RankNTypes 22 | -- 23 | -- Convenient type families for working with type-level @Maybe@s. 24 | ---------------------------------------------------------------------------- 25 | 26 | module Type.Family.Maybe where 27 | 28 | import Type.Family.Constraint 29 | import Type.Family.Monoid 30 | import Type.Class.Witness 31 | 32 | -- | Take a @Maybe Constraint@ to a @Constraint@. 33 | type family MaybeC (mc :: Maybe Constraint) :: Constraint where 34 | MaybeC Nothing = ØC 35 | MaybeC (Just c) = c 36 | 37 | type family IsNothing (a :: Maybe k) :: Bool where 38 | IsNothing Nothing = True 39 | IsNothing (Just a) = False 40 | 41 | nothingCong :: (a ~ b) :- (IsNothing a ~ IsNothing b) 42 | nothingCong = Sub Wit 43 | 44 | nothingNotJust :: (Nothing ~ Just a) :- Fail 45 | nothingNotJust = nothingCong 46 | 47 | -- | Map over a type-level @Maybe@. 48 | type family (f :: k -> l) <$> (a :: Maybe k) :: Maybe l where 49 | f <$> Nothing = Nothing 50 | f <$> Just a = Just (f a) 51 | infixr 4 <$> 52 | 53 | maybeFmapCong :: (f ~ g,a ~ b) :- ((f <$> a) ~ (g <$> b)) 54 | maybeFmapCong = Sub Wit 55 | 56 | type family (f :: Maybe (k -> l)) <&> (a :: k) :: Maybe l where 57 | Nothing <&> a = Nothing 58 | Just f <&> a = Just (f a) 59 | infixl 5 <&> 60 | 61 | maybePamfCong :: (f ~ g,a ~ b) :- ((f <&> a) ~ (g <&> b)) 62 | maybePamfCong = Sub Wit 63 | 64 | type family (f :: Maybe (k -> l)) <*> (a :: Maybe k) :: Maybe l where 65 | Nothing <*> a = Nothing 66 | f <*> Nothing = Nothing 67 | Just f <*> Just a = Just (f a) 68 | infixr 4 <*> 69 | 70 | maybeApCong :: (f ~ g,a ~ b) :- ((f <*> a) ~ (g <*> b)) 71 | maybeApCong = Sub Wit 72 | 73 | type family (a :: Maybe k) <|> (b :: Maybe k) :: Maybe k where 74 | Nothing <|> a = a 75 | a <|> Nothing = a 76 | Just a <|> Just b = Just a 77 | infixr 4 <|> 78 | 79 | maybeAltCong :: (a ~ c,b ~ d) :- ((a <|> b) ~ (c <|> d)) 80 | maybeAltCong = Sub Wit 81 | 82 | type family FromJust (m :: Maybe k) :: k where 83 | FromJust (Just a) = a 84 | 85 | fromJustCong :: (a ~ b) :- (FromJust a ~ FromJust b) 86 | fromJustCong = Sub Wit 87 | 88 | type instance Mempty = Nothing 89 | type instance a <> b = a <|> b 90 | 91 | -------------------------------------------------------------------------------- /src/Type/Family/Either.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE KindSignatures #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE GADTs #-} 13 | ----------------------------------------------------------------------------- 14 | -- | 15 | -- Module : Type.Family.Either 16 | -- Copyright : Copyright (C) 2015 Kyle Carter 17 | -- License : BSD3 18 | -- 19 | -- Maintainer : Kyle Carter 20 | -- Stability : experimental 21 | -- Portability : RankNTypes 22 | -- 23 | -- Convenient type families for working with type-level @Either@s. 24 | ---------------------------------------------------------------------------- 25 | 26 | module Type.Family.Either where 27 | 28 | import Type.Family.Constraint 29 | import Type.Family.Monoid 30 | import Type.Class.Witness 31 | 32 | -- | Take a @Maybe Constraint@ to a @Constraint@. 33 | type family EitherC (ec :: Either k Constraint) :: Constraint where 34 | EitherC (Left a) = ØC 35 | EitherC (Right c) = c 36 | 37 | type family IsLeft (a :: Either k l) :: Bool where 38 | IsLeft (Left a) = True 39 | IsLeft (Right b) = False 40 | 41 | type family IsRight (a :: Either k l) :: Bool where 42 | IsRight (Left a) = False 43 | IsRight (Right b) = True 44 | 45 | leftCong :: (a ~ b) :- (IsLeft a ~ IsLeft b) 46 | leftCong = Sub Wit 47 | 48 | rightCong :: (a ~ b) :- (IsRight a ~ IsRight b) 49 | rightCong = Sub Wit 50 | 51 | leftNotRight :: (Left a ~ Right b) :- Fail 52 | leftNotRight = leftCong 53 | 54 | -- | Map over a type-level @Maybe@. 55 | type family (f :: k -> l) <$> (a :: Either m k) :: Either m l where 56 | f <$> Left a = Left a 57 | f <$> Right b = Right (f b) 58 | infixr 4 <$> 59 | 60 | eitherFmapCong :: (f ~ g,a ~ b) :- ((f <$> a) ~ (g <$> b)) 61 | eitherFmapCong = Sub Wit 62 | 63 | type family (f :: Either m (k -> l)) <&> (a :: k) :: Either m l where 64 | Left x <&> a = Left x 65 | Right f <&> a = Right (f a) 66 | infixl 5 <&> 67 | 68 | eitherPamfCong :: (f ~ g,a ~ b) :- ((f <&> a) ~ (g <&> b)) 69 | eitherPamfCong = Sub Wit 70 | 71 | type family (f :: Either m (k -> l)) <*> (a :: Either m k) :: Either m l where 72 | Left x <*> Left y = Left (x <> y) 73 | Left x <*> a = Left x 74 | f <*> Left x = Left x 75 | Right f <*> Right a = Right (f a) 76 | infixr 4 <*> 77 | 78 | eitherApCong :: (f ~ g,a ~ b) :- ((f <*> a) ~ (g <*> b)) 79 | eitherApCong = Sub Wit 80 | 81 | type family (a :: Either m k) <|> (b :: Either m k) :: Either m k where 82 | Left x <|> b = b 83 | Right a <|> b = Right a 84 | infixr 4 <|> 85 | 86 | eitherAltCong :: (a ~ c,b ~ d) :- ((a <|> b) ~ (c <|> d)) 87 | eitherAltCong = Sub Wit 88 | 89 | type family FromLeft (e :: Either k l) :: k where 90 | FromLeft (Left a) = a 91 | 92 | type family FromRight (e :: Either k l) :: l where 93 | FromRight (Right b) = b 94 | 95 | fromLeftCong :: (a ~ b) :- (FromLeft a ~ FromLeft b) 96 | fromLeftCong = Sub Wit 97 | 98 | fromRightCong :: (a ~ b) :- (FromRight a ~ FromRight b) 99 | fromRightCong = Sub Wit 100 | 101 | type instance Mempty = Left Mempty 102 | type instance a <> b = a <|> b 103 | 104 | -------------------------------------------------------------------------------- /src/Data/Type/Boolean.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE GADTs #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Type.Boolean 18 | -- Copyright : Copyright (C) 2015 Kyle Carter 19 | -- License : BSD3 20 | -- 21 | -- Maintainer : Kyle Carter 22 | -- Stability : experimental 23 | -- Portability : RankNTypes 24 | -- 25 | -- A @singleton@-esque type for type-level Bool values. 26 | -- 27 | ----------------------------------------------------------------------------- 28 | 29 | module Data.Type.Boolean where 30 | 31 | -- import Data.Type.Quantifier (Some(..)) 32 | import Type.Family.Bool 33 | import Type.Class.Known 34 | import Type.Class.Higher 35 | import Type.Class.Witness 36 | 37 | data Boolean :: Bool -> * where 38 | False_ :: Boolean False 39 | True_ :: Boolean True 40 | 41 | deriving instance Eq (Boolean b) 42 | deriving instance Ord (Boolean b) 43 | deriving instance Show (Boolean b) 44 | 45 | instance Eq1 Boolean 46 | instance Ord1 Boolean 47 | instance Show1 Boolean 48 | 49 | instance Read1 Boolean where 50 | readsPrec1 _ s0 = 51 | [ (Some True_,s1) 52 | | ("True_",s1) <- lex s0 53 | ] ++ 54 | [ (Some False_,s1) 55 | | ("False_",s1) <- lex s0 56 | ] 57 | 58 | if' :: Boolean b -> ((b ~ True) => a) -> ((b ~ False) => a) -> a 59 | if' t c a = case t of 60 | True_ -> c 61 | False_ -> a 62 | 63 | (.?) :: ((b ~ True) => a) -> ((b ~ False) => a) -> Boolean b -> a 64 | (c .? a) t = if' t c a 65 | infix 4 .? 66 | 67 | not' :: Boolean a -> Boolean (Not a) 68 | not' = False_ .? True_ 69 | 70 | (.||) :: Boolean a -> Boolean b -> Boolean (a || b) 71 | (.||) = (True_ .? True_ ) 72 | .? (True_ .? False_) 73 | infixr 2 .|| 74 | 75 | (.&&) :: Boolean a -> Boolean b -> Boolean (a && b) 76 | (.&&) = (True_ .? False_) 77 | .? (False_ .? False_) 78 | infixr 3 .&& 79 | 80 | (.^^) :: Boolean a -> Boolean b -> Boolean (a ^^ b) 81 | (.^^) = (False_ .? True_ ) 82 | .? (True_ .? False_) 83 | infixr 4 .^^ 84 | 85 | (==>) :: Boolean a -> Boolean b -> Boolean (a ==> b) 86 | (==>) = (True_ .? False_) 87 | .? (True_ .? True_ ) 88 | infixr 1 ==> 89 | 90 | (<==>) :: Boolean a -> Boolean b -> Boolean (a <==> b) 91 | (<==>) = (True_ .? False_) 92 | .? (False_ .? True_ ) 93 | infixr 1 <==> 94 | 95 | class BoolEquality (f :: k -> *) where 96 | boolEquality :: f a -> f b -> Boolean (a == b) 97 | 98 | (.==) :: BoolEquality f => f a -> f b -> Boolean (a == b) 99 | (.==) = boolEquality 100 | infix 4 .== 101 | 102 | instance BoolEquality Boolean where 103 | boolEquality = (<==>) 104 | 105 | instance TestEquality Boolean where 106 | testEquality = (qed .? Nothing) .? (Nothing .? qed) 107 | 108 | instance Known Boolean True where 109 | known = True_ 110 | 111 | instance Known Boolean False where 112 | known = False_ 113 | 114 | toBool :: Boolean b -> Bool 115 | toBool = True .? False 116 | 117 | -------------------------------------------------------------------------------- /src/Data/Type/Fin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE ConstraintKinds #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE LambdaCase #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# LANGUAGE KindSignatures #-} 14 | {-# LANGUAGE DataKinds #-} 15 | {-# LANGUAGE PolyKinds #-} 16 | {-# LANGUAGE GADTs #-} 17 | ----------------------------------------------------------------------------- 18 | -- | 19 | -- Module : Data.Type.Fin 20 | -- Copyright : Copyright (C) 2015 Kyle Carter 21 | -- License : BSD3 22 | -- 23 | -- Maintainer : Kyle Carter 24 | -- Stability : experimental 25 | -- Portability : RankNTypes 26 | -- 27 | -- A @singleton@-esque type for representing members of finite sets. 28 | -- 29 | ----------------------------------------------------------------------------- 30 | 31 | module Data.Type.Fin where 32 | 33 | import Data.Type.Nat 34 | import Type.Class.Higher 35 | import Type.Class.Known 36 | import Type.Class.Witness 37 | import Type.Family.Constraint 38 | import Type.Family.Nat 39 | -- import Data.Type.Quantifier 40 | 41 | data Fin :: N -> * where 42 | FZ :: Fin (S n) 43 | FS :: !(Fin n) -> Fin (S n) 44 | 45 | deriving instance Eq (Fin n) 46 | deriving instance Ord (Fin n) 47 | deriving instance Show (Fin n) 48 | 49 | instance Eq1 Fin 50 | instance Ord1 Fin 51 | instance Show1 Fin 52 | 53 | instance Read1 Fin where 54 | readsPrec1 d = readParen (d > 10) $ \s0 -> 55 | [ (Some FZ,s1) 56 | | ("FZ",s1) <- lex s0 57 | ] ++ 58 | [ (n >>- Some . FS,s2) 59 | | ("FS",s1) <- lex s0 60 | , (n,s2) <- readsPrec1 11 s1 61 | ] 62 | 63 | instance (Known Nat n, Pos n) => Enum (Fin n) where 64 | toEnum n 65 | | n <= 0 = FZ 66 | | otherwise = case (known :: Nat n) of 67 | S_ Z_ -> FZ 68 | S_ S_{} -> FS $ toEnum (n-1) 69 | fromEnum = fin 70 | 71 | instance (Known Nat n, Pos n) => Bounded (Fin n) where 72 | minBound = FZ 73 | maxBound = case (known :: Nat n) of 74 | S_ Z_ -> FZ 75 | S_ S_{} -> FS maxBound 76 | 77 | elimFin :: (forall x. p (S x)) 78 | -> (forall x. Fin x -> p x -> p (S x)) 79 | -> Fin n -> p n 80 | elimFin z s = \case 81 | FZ -> z 82 | FS n -> s n $ elimFin z s n 83 | 84 | -- | Gives the list of all members of the finite set of size @n@. 85 | fins :: Nat n -> [Fin n] 86 | fins = \case 87 | Z_ -> [] 88 | S_ x -> FZ : map FS (fins x) 89 | 90 | fin :: Fin n -> Int 91 | fin = \case 92 | FZ -> 0 93 | FS x -> succ $ fin x 94 | 95 | -- | There are no members of @Fin Z@. 96 | finZ :: Fin Z -> Void 97 | finZ = impossible 98 | 99 | weaken :: Fin n -> Fin (S n) 100 | weaken = \case 101 | FZ -> FZ 102 | FS n -> FS $ weaken n 103 | 104 | -- | Map a finite set to a lower finite set without 105 | -- one of its members. 106 | without :: Fin n -> Fin n -> Maybe (Fin (Pred n)) 107 | without = \case 108 | FZ -> \case 109 | FZ -> Nothing 110 | FS y -> Just y 111 | FS x -> \case 112 | FZ -> Just FZ \\ x 113 | FS y -> FS <$> without x y \\ x 114 | 115 | -- | Take a 'Fin' to an existentially quantified 'Nat'. 116 | finNat :: Fin x -> Some Nat 117 | finNat = \case 118 | FZ -> Some Z_ 119 | FS x -> withSome (Some . S_) $ finNat x 120 | 121 | -- | A @Fin n@ is a 'Witness' that @n >= 1@. 122 | -- 123 | -- That is, @'Pred' n@ is well defined. 124 | instance (n' ~ Pred n) => Witness ØC (S n' ~ n) (Fin n) where 125 | type WitnessC ØC (S n' ~ n) (Fin n) = (n' ~ Pred n) 126 | (\\) r = \case 127 | FZ -> r 128 | FS _ -> r 129 | 130 | -------------------------------------------------------------------------------- /src/Data/Type/Index.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableSuperClasses #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE ConstraintKinds #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE LambdaCase #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# LANGUAGE KindSignatures #-} 14 | {-# LANGUAGE DataKinds #-} 15 | {-# LANGUAGE PolyKinds #-} 16 | {-# LANGUAGE GADTs #-} 17 | ----------------------------------------------------------------------------- 18 | -- | 19 | -- Module : Data.Type.Index 20 | -- Copyright : Copyright (C) 2015 Kyle Carter 21 | -- License : BSD3 22 | -- 23 | -- Maintainer : Kyle Carter 24 | -- Stability : experimental 25 | -- Portability : RankNTypes 26 | -- 27 | -- A @singleton@-esque type for representing indices in a type-level list. 28 | -- 29 | ----------------------------------------------------------------------------- 30 | 31 | module Data.Type.Index where 32 | 33 | -- import Data.Type.Quantifier 34 | import Type.Class.Higher 35 | import Type.Class.Known 36 | import Type.Class.Witness 37 | import Type.Family.Constraint 38 | import Type.Family.List 39 | 40 | data Index :: [k] -> k -> * where 41 | IZ :: Index (a :< as) a 42 | IS :: !(Index as a) -> Index (b :< as) a 43 | 44 | deriving instance Eq (Index as a) 45 | deriving instance Ord (Index as a) 46 | deriving instance Show (Index as a) 47 | 48 | instance Eq1 (Index as) 49 | instance Ord1 (Index as) 50 | instance Show1 (Index as) 51 | 52 | instance Read2 Index where 53 | readsPrec2 d = readParen (d > 10) $ \s0 -> 54 | [ (Some2 IZ,s1) 55 | | ("IZ",s1) <- lex s0 56 | ] ++ 57 | [ (i >>-- Some2 . IS,s2) 58 | | ("IS",s1) <- lex s0 59 | , (i,s2) <- readsPrec2 11 s1 60 | ] 61 | 62 | instance TestEquality (Index as) where 63 | testEquality = \case 64 | IZ -> \case 65 | IZ -> qed 66 | _ -> Nothing 67 | IS x -> \case 68 | IS y -> x =?= y //? qed 69 | _ -> Nothing 70 | 71 | elimIndex :: (forall xs. p (a :< xs) a) 72 | -> (forall x xs. Index xs a -> p xs a -> p (x :< xs) a) 73 | -> Index as a 74 | -> p as a 75 | elimIndex z s = \case 76 | IZ -> z 77 | IS x -> s x $ elimIndex z s x 78 | 79 | ixNil :: Index Ø a -> b 80 | ixNil = absurd . impossible 81 | 82 | onIxPred :: (Index as a -> Index bs a) -> Index (b :< as) a -> Index (b :< bs) a 83 | onIxPred f = \case 84 | IZ -> IZ 85 | IS x -> IS $ f x 86 | 87 | type a ∈ as = Elem as a 88 | infix 6 ∈ 89 | 90 | class Elem (as :: [k]) (a :: k) where 91 | elemIndex :: Index as a 92 | 93 | instance {-# OVERLAPPING #-} Elem (a :< as) a where 94 | elemIndex = IZ 95 | 96 | instance {-# OVERLAPPABLE #-} Elem as a => Elem (b :< as) a where 97 | elemIndex = IS elemIndex 98 | 99 | instance Witness ØC (Elem as a) (Index as a) where 100 | (\\) r = \case 101 | IZ -> r 102 | IS x -> r \\ x 103 | 104 | instance (a ∈ as) => Known (Index as) a where 105 | type KnownC (Index as) a = (a ∈ as) 106 | known = elemIndex 107 | 108 | class EveryC c as => Every (c :: k -> Constraint) (as :: [k]) where 109 | type EveryC c as :: Constraint 110 | every :: Index as a -> Wit (c a) 111 | 112 | instance Every c Ø where 113 | type EveryC c Ø = ØC 114 | every = ixNil 115 | 116 | instance (c a, Every c as) => Every c (a :< as) where 117 | type EveryC c (a :< as) = (c a, Every c as) 118 | every = \case 119 | IZ -> Wit 120 | IS x -> every x 121 | 122 | class ListC ((c <$> xs) <&> y) 123 | => Every2 (c :: k -> l -> Constraint) (xs :: [k]) (y :: l) where 124 | every2 :: Index xs x -> Wit (c x y) 125 | 126 | instance Every2 c Ø y where 127 | every2 = ixNil 128 | 129 | instance (c x y, Every2 c xs y) => Every2 c (x :< xs) y where 130 | every2 = \case 131 | IZ -> Wit 132 | IS x -> every2 x 133 | 134 | 135 | 136 | -------------------------------------------------------------------------------- /src/Data/Type/Sum/Lifted.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE KindSignatures #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE GADTs #-} 13 | ----------------------------------------------------------------------------- 14 | -- | 15 | -- Module : Data.Type.Sum.Lifted 16 | -- Copyright : Copyright (C) 2015 Kyle Carter 17 | -- License : BSD3 18 | -- 19 | -- Maintainer : Kyle Carter 20 | -- Stability : experimental 21 | -- Portability : RankNTypes 22 | -- 23 | -- 'FSum' is a type combinators for representing disjoint sums of 24 | -- many functors @(fs :: [k -> *])@ at a single index @(a :: k)@. 25 | -- As opposed to one-functor-many-indices 'Sum'. 26 | -- 27 | ----------------------------------------------------------------------------- 28 | 29 | module Data.Type.Sum.Lifted where 30 | 31 | import Data.Type.Index 32 | import Type.Class.Witness 33 | import Type.Family.List 34 | 35 | data FSum :: [k -> *] -> k -> * where 36 | FInL :: !(f a) -> FSum (f :< fs) a 37 | FInR :: !(FSum fs a) -> FSum (f :< fs) a 38 | 39 | -- | There are no possible values of the type @FSum Ø a@. 40 | nilFSum :: FSum Ø a -> Void 41 | nilFSum = impossible 42 | 43 | -- | Decompose a non-empty FSum into either its head or its tail. 44 | fdecomp :: FSum (f :< fs) a -> Either (f a) (FSum fs a) 45 | fdecomp = \case 46 | FInL a -> Left a 47 | FInR s -> Right s 48 | 49 | -- | Inject an element into an FSum. 50 | finj :: (f ∈ fs) => f a -> FSum fs a 51 | finj = injectFSum elemIndex 52 | 53 | -- | Project an implicit index out of an FSum. 54 | fprj :: (f ∈ fs) => FSum fs a -> Maybe (f a) 55 | fprj = findex elemIndex 56 | 57 | -- | Inject an element into an FSum with an explicitly 58 | -- specified Index. 59 | injectFSum :: Index fs f -> f a -> FSum fs a 60 | injectFSum = \case 61 | IZ -> FInL 62 | IS x -> FInR . injectFSum x 63 | 64 | -- | Project an explicit index out of an FSum. 65 | findex :: Index fs f -> FSum fs a -> Maybe (f a) 66 | findex = \case 67 | IZ -> \case 68 | FInL a -> Just a 69 | _ -> Nothing 70 | IS x -> \case 71 | FInR s -> findex x s 72 | _ -> Nothing 73 | 74 | instance ListC (Functor <$> fs) => Functor (FSum fs) where 75 | fmap f = \case 76 | FInL a -> FInL $ f <$> a 77 | FInR s -> FInR $ f <$> s 78 | 79 | instance ListC (Foldable <$> fs) => Foldable (FSum fs) where 80 | foldMap f = \case 81 | FInL a -> foldMap f a 82 | FInR s -> foldMap f s 83 | 84 | instance 85 | ( ListC (Functor <$> fs) 86 | , ListC (Foldable <$> fs) 87 | , ListC (Traversable <$> fs) 88 | ) => Traversable (FSum fs) where 89 | traverse f = \case 90 | FInL a -> FInL <$> traverse f a 91 | FInR s -> FInR <$> traverse f s 92 | 93 | -- | Map over the single element in an FSum 94 | -- with a function that can handle any possible 95 | -- element, along with the element's index. 96 | imapFSum :: (forall f. Index fs f -> f a -> f b) 97 | -> FSum fs a -> FSum fs b 98 | imapFSum f = \case 99 | FInL a -> FInL $ f IZ a 100 | FInR s -> FInR $ imapFSum (f . IS) s 101 | 102 | -- | Fun fact: Since there is exactly one element in 103 | -- an FSum, we don't need the @Monoid@ instance! 104 | ifoldMapFSum :: (forall f. Index fs f -> f a -> m) 105 | -> FSum fs a -> m 106 | ifoldMapFSum f = \case 107 | FInL a -> f IZ a 108 | FInR s -> ifoldMapFSum (f . IS) s 109 | 110 | -- | Another fun fact: Since there is exactly one element in 111 | -- an FSum, we require only a @Functor@ instance on @g@, rather 112 | -- than @Applicative@. 113 | itraverseFSum :: Functor g 114 | => (forall f. Index fs f -> f a -> g (f b)) 115 | -> FSum fs a -> g (FSum fs b) 116 | itraverseFSum f = \case 117 | FInL a -> FInL <$> f IZ a 118 | FInR s -> FInR <$> itraverseFSum (f . IS) s 119 | 120 | -------------------------------------------------------------------------------- /src/Type/Family/Nat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilyDependencies #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE FunctionalDependencies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE LambdaCase #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE DataKinds #-} 14 | {-# LANGUAGE PolyKinds #-} 15 | {-# LANGUAGE GADTs #-} 16 | ----------------------------------------------------------------------------- 17 | -- | 18 | -- Module : Type.Family.Nat 19 | -- Copyright : Copyright (C) 2015 Kyle Carter 20 | -- License : BSD3 21 | -- 22 | -- Maintainer : Kyle Carter 23 | -- Stability : experimental 24 | -- Portability : RankNTypes 25 | -- 26 | -- Type-level natural numbers, along with frequently used 27 | -- type families over them. 28 | -- 29 | ----------------------------------------------------------------------------- 30 | 31 | module Type.Family.Nat where 32 | 33 | import Data.Type.Equality 34 | import Type.Family.Bool 35 | import Type.Family.Constraint 36 | import Type.Family.List 37 | import Type.Class.Witness 38 | 39 | data N 40 | = Z 41 | | S N 42 | deriving (Eq,Ord,Show) 43 | 44 | fromInt :: Int -> Maybe N 45 | fromInt n = case compare n 0 of 46 | LT -> Nothing 47 | EQ -> Just Z 48 | GT -> S <$> fromInt (n-1) 49 | 50 | type family IsZero (x :: N) :: Bool where 51 | IsZero Z = True 52 | IsZero (S x) = False 53 | 54 | zeroCong :: (x ~ y) :- (IsZero x ~ IsZero y) 55 | zeroCong = Sub Wit 56 | 57 | zNotS :: (Z ~ S x) :- Fail 58 | zNotS = zeroCong 59 | 60 | -- | Note: Was previously a type family, but is now just a synonym for '==' 61 | -- from 'Data.Type.Equality'. 62 | type NatEq (x :: N) (y :: N) = x == y 63 | 64 | type family Iota (x :: N) = (xs :: [N]) | xs -> x where 65 | Iota Z = Ø 66 | Iota (S x) = x :< Iota x 67 | 68 | iotaCong :: (x ~ y) :- (Iota x ~ Iota y) 69 | iotaCong = Sub Wit 70 | 71 | type family Pred (x :: N) :: N where 72 | Pred (S n) = n 73 | 74 | type Pos n = (n ~ S (Pred n)) 75 | 76 | predCong :: (x ~ y) :- (Pred x ~ Pred y) 77 | predCong = Sub Wit 78 | 79 | type family (x :: N) + (y :: N) :: N where 80 | Z + y = y 81 | S x + y = S (x + y) 82 | infixr 6 + 83 | 84 | data AddW (f :: N -> *) :: N -> * where 85 | AddW :: !(f x) 86 | -> !(f y) 87 | -> AddW f (x + y) 88 | 89 | addCong :: (w ~ y,x ~ z) :- ((w + x) ~ (y + z)) 90 | addCong = Sub Wit 91 | 92 | type family (x :: N) * (y :: N) :: N where 93 | Z * y = Z 94 | S x * y = (x * y) + y 95 | infixr 7 * 96 | 97 | data MulW (f :: N -> *) :: N -> * where 98 | MulW :: !(f x) 99 | -> !(f y) 100 | -> MulW f (x * y) 101 | 102 | mulCong :: (w ~ y,x ~ z) :- ((w * x) ~ (y * z)) 103 | mulCong = Sub Wit 104 | 105 | type family (x :: N) ^ (y :: N) :: N where 106 | x ^ Z = S Z 107 | x ^ S y = (x ^ y) * x 108 | infixl 8 ^ 109 | 110 | expCong :: (w ~ y,x ~ z) :- ((w ^ x) ~ (y ^ z)) 111 | expCong = Sub Wit 112 | 113 | type family Len (as :: [k]) :: N where 114 | Len Ø = Z 115 | Len (a :< as) = S (Len as) 116 | 117 | lenCong :: (as ~ bs) :- (Len as ~ Len bs) 118 | lenCong = Sub Wit 119 | 120 | type family Ix (x :: N) (as :: [k]) :: k where 121 | Ix Z (a :< as) = a 122 | Ix (S x) (a :< as) = Ix x as 123 | 124 | ixCong :: (x ~ y,as ~ bs) :- (Ix x as ~ Ix y bs) 125 | ixCong = Sub Wit 126 | 127 | type family (x :: N) < (y :: N) :: Bool where 128 | Z < Z = False 129 | Z < S y = True 130 | S x < Z = False 131 | S x < S y = x < y 132 | infix 4 < 133 | 134 | type x <= y = (x == y) || (x < y) 135 | infix 4 <= 136 | 137 | type family (x :: N) > (y :: N) :: Bool where 138 | Z > Z = False 139 | Z > S y = False 140 | S x > Z = True 141 | S x > S y = x > y 142 | infix 4 > 143 | 144 | type x >= y = (x == y) || (x > y) 145 | infix 4 >= 146 | 147 | -- | Convenient aliases for low-value Peano numbers. 148 | type N0 = Z 149 | type N1 = S N0 150 | type N2 = S N1 151 | type N3 = S N2 152 | type N4 = S N3 153 | type N5 = S N4 154 | type N6 = S N5 155 | type N7 = S N6 156 | type N8 = S N7 157 | type N9 = S N8 158 | type N10 = S N9 159 | 160 | -------------------------------------------------------------------------------- /src/Data/Type/Nat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE GADTs #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Type.Nat 18 | -- Copyright : Copyright (C) 2015 Kyle Carter 19 | -- License : BSD3 20 | -- 21 | -- Maintainer : Kyle Carter 22 | -- Stability : experimental 23 | -- Portability : RankNTypes 24 | -- 25 | -- A @singleton@-esque type for representing Peano natural numbers. 26 | -- 27 | ----------------------------------------------------------------------------- 28 | 29 | module Data.Type.Nat where 30 | 31 | import Data.Type.Boolean 32 | import Data.Type.Equality 33 | -- import Data.Type.Quantifier 34 | import Type.Class.Higher 35 | import Type.Class.Known 36 | import Type.Class.Witness 37 | import Type.Family.Constraint 38 | import Type.Family.Nat 39 | -- import Type.Class.Categories 40 | 41 | data Nat :: N -> * where 42 | Z_ :: Nat Z 43 | S_ :: !(Nat n) -> Nat (S n) 44 | 45 | deriving instance Eq (Nat n) 46 | deriving instance Ord (Nat n) 47 | deriving instance Show (Nat n) 48 | 49 | instance Eq1 Nat 50 | instance Ord1 Nat 51 | instance Show1 Nat 52 | 53 | instance Read1 Nat where 54 | readsPrec1 d = readParen (d > 10) $ \s0 -> 55 | [ (Some Z_,s1) 56 | | ("Z_",s1) <- lex s0 57 | ] ++ 58 | [ (n >>- Some . S_,s2) 59 | | ("S_",s1) <- lex s0 60 | , (n,s2) <- readsPrec1 11 s1 61 | ] 62 | 63 | -- | @'Z_'@ is the canonical construction of a @'Nat' Z@. 64 | instance Known Nat Z where 65 | known = Z_ 66 | 67 | -- | If @n@ is a canonical construction of @Nat n@, 68 | -- @'S_' n@ is the canonical construction of @Nat (S n)@. 69 | instance Known Nat n => Known Nat (S n) where 70 | type KnownC Nat (S n) = Known Nat n 71 | known = S_ known 72 | 73 | -- | A @Nat n@ is a 'Witness' that there is a canonical 74 | -- construction for @Nat n@. 75 | instance Witness ØC (Known Nat n) (Nat n) where 76 | (\\) r = \case 77 | Z_ -> r 78 | S_ x -> r \\ x 79 | 80 | instance TestEquality Nat where 81 | testEquality = \case 82 | Z_ -> \case 83 | Z_ -> Just Refl 84 | S_ _ -> Nothing 85 | S_ x -> \case 86 | Z_ -> Nothing 87 | S_ y -> testEquality x y //? qed 88 | 89 | instance BoolEquality Nat where 90 | boolEquality = \case 91 | Z_ -> \case 92 | Z_ -> True_ 93 | S_ _ -> False_ 94 | S_ x -> \case 95 | Z_ -> False_ 96 | S_ y -> x .== y 97 | 98 | pred' :: Nat (S x) -> Nat x 99 | pred' (S_ x) = x 100 | 101 | onNatPred :: (Nat x -> Nat y) -> Nat (S x) -> Nat (S y) 102 | onNatPred f (S_ x) = S_ $ f x 103 | 104 | _Z :: Z :~: Z 105 | _Z = Refl 106 | 107 | _S :: x :~: y -> S x :~: S y 108 | _S Refl = Refl 109 | 110 | _s :: S x :~: S y -> x :~: y 111 | _s Refl = Refl 112 | 113 | _ZneS :: Z :~: S x -> Void 114 | _ZneS = impossible 115 | 116 | -- | A proof that 'Z' is also a right identity 117 | -- for the addition of type-level 'Nat's. 118 | addZ :: Nat x -> (x + Z) :~: x 119 | addZ = \case 120 | Z_ -> Refl 121 | S_ x -> _S $ addZ x 122 | {-# INLINE addZ #-} 123 | 124 | addS :: Nat x -> Nat y -> S (x + y) :~: (x + S y) 125 | addS = \case 126 | Z_ -> pure Refl 127 | S_ x -> _S . addS x 128 | {-# INLINE addS #-} 129 | 130 | (.+) :: Nat x -> Nat y -> Nat (x + y) 131 | (.+) = \case 132 | Z_ -> id 133 | S_ x -> S_ . (x .+) 134 | infixr 6 .+ 135 | 136 | (.*) :: Nat x -> Nat y -> Nat (x * y) 137 | (.*) = \case 138 | Z_ -> const Z_ 139 | S_ x -> (.+) <$> (x .*) <*> id 140 | infixr 7 .* 141 | 142 | (.^) :: Nat x -> Nat y -> Nat (x ^ y) 143 | (.^) x = \case 144 | Z_ -> S_ Z_ 145 | S_ y -> (x .^ y) .* x 146 | infixl 8 .^ 147 | 148 | elimNat :: p Z -> (forall x. Nat x -> p x -> p (S x)) -> Nat n -> p n 149 | elimNat z s = \case 150 | Z_ -> z 151 | S_ x -> s x $ elimNat z s x 152 | 153 | natVal :: Nat n -> Int 154 | natVal = \case 155 | Z_ -> 0 156 | S_ x -> succ $ natVal x 157 | 158 | -------------------------------------------------------------------------------- /src/Data/Type/Product/Env.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE FlexibleContexts #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-# LANGUAGE LambdaCase #-} 14 | 15 | module Data.Type.Product.Env where 16 | 17 | import Data.Type.Combinator (Comp1(..)) 18 | import Data.Type.Conjunction 19 | import Data.Type.Boolean 20 | import Data.Type.Index 21 | import Data.Type.Index.Trans 22 | import Data.Type.Option 23 | import Data.Type.Product 24 | import Type.Class.Higher 25 | import Type.Class.Witness 26 | import Type.Family.Bool 27 | import Type.Family.List 28 | 29 | newtype Env k v ps = Env 30 | { getEnv :: Prod (k :*: v) ps 31 | } 32 | 33 | type family Member (x :: k) (ps :: [(k,v)]) :: Bool where 34 | Member x Ø = False 35 | Member x ('(y,a) :< ps) = (x == y) || Member x ps 36 | 37 | member' :: BoolEquality k => k x -> Env k v ps -> Boolean (Member x ps) 38 | member' x = (. getEnv) $ \case 39 | Ø -> False_ 40 | (y :*: _) :< ps -> (x .== y) .|| member' x (Env ps) 41 | 42 | type family Lookup (x :: k) (ps :: [(k,v)]) :: Maybe v where 43 | Lookup x Ø = Nothing 44 | Lookup x ('(y,a) :< ps) = If (x == y) (Just a) (Lookup x ps) 45 | 46 | lookup' :: BoolEquality k => k x -> Env k v ps -> Option v (Lookup x ps) 47 | lookup' x = (. getEnv) $ \case 48 | Ø -> Nothing_ 49 | (y :*: a) :< ps -> if' (x .== y) 50 | (Just_ a) 51 | (lookup' x $ Env ps) 52 | 53 | type family Insert (x :: k) (a :: v) (ps :: [(k,v)]) :: [(k,v)] where 54 | Insert x a Ø = '[ '(x,a) ] 55 | Insert x a ('(y,b) :< ps) = If (x == y) ('(x,a) :< ps) ('(y,b) :< Insert x a ps) 56 | 57 | insert' :: BoolEquality k => k x -> v a -> Env k v ps -> Env k v (Insert x a ps) 58 | insert' x a = (. getEnv) $ \case 59 | Ø -> Env $ (x :*: a) :< Ø 60 | (y :*: b) :< ps -> if' (x .== y) 61 | (Env $ (x :*: a) :< ps) 62 | (Env $ (y :*: b) :< getEnv (insert' x a (Env ps))) 63 | 64 | type family Delete (x :: k) (ps :: [(k,v)]) :: [(k,v)] where 65 | Delete x Ø = Ø 66 | Delete x ('(y,a) :< ps) = If (x == y) ps ('(y,a) :< Delete x ps) 67 | 68 | delete' :: BoolEquality k => k x -> Env k v ps -> Env k v (Delete x ps) 69 | delete' x = (. getEnv) $ \case 70 | Ø -> Env Ø 71 | (y :*: a) :< ps -> if' (x .== y) 72 | (Env ps) 73 | (Env $ (y :*: a) :< getEnv (delete' x (Env ps))) 74 | 75 | type family Difference (ps :: [(k,v)]) (qs :: [(k,w)]) :: [(k,v)] where 76 | Difference ps Ø = ps 77 | Difference ps ('(x,a) :< qs) = Delete x (Difference ps qs) 78 | 79 | difference' :: BoolEquality k => Env k v ps -> Env k w qs -> Env k v (Difference ps qs) 80 | difference' ps = (. getEnv) $ \case 81 | Ø -> ps 82 | (x :*: _) :< qs -> delete' x $ difference' ps (Env qs) 83 | 84 | (.\\) :: BoolEquality k => Env k v ps -> Env k w qs -> Env k v (Difference ps qs) 85 | (.\\) = difference' 86 | 87 | type family Union (ps :: [(k,v)]) (qs :: [(k,v)]) :: [(k,v)] where 88 | Union ps Ø = ps 89 | Union ps ('(x,a) :< qs) = Insert x a (Union ps qs) 90 | 91 | union' :: BoolEquality k => Env k v ps -> Env k v qs -> Env k v (Union ps qs) 92 | union' ps = (. getEnv) $ \case 93 | Ø -> ps 94 | (x :*: a) :< qs -> insert' x a $ union' ps (Env qs) 95 | 96 | type family Intersection (ps :: [(k,v)]) (qs :: [(k,w)]) :: [(k,v)] where 97 | Intersection Ø qs = Ø 98 | Intersection ('(x,a) :< ps) qs = If (Member x qs) ('(x,a) :< Intersection ps qs) (Intersection ps qs) 99 | 100 | intersection' :: BoolEquality k => Env k v ps -> Env k w qs -> Env k v (Intersection ps qs) 101 | intersection' ps qs = case getEnv ps of 102 | Ø -> Env Ø 103 | (x :*: a) :< ps' -> if' (member' x qs) (Env $ (x :*: a) :< getEnv rest) rest 104 | where 105 | rest = intersection' (Env ps') qs 106 | 107 | instance Functor1 (Env k) where 108 | map1 f = Env . getComp1 . map1 f . Comp1 . getEnv 109 | 110 | instance IxFunctor1 (IxList (IxSecond (:~:))) (Env k) where 111 | imap1 f = Env . imap1 (\i -> imap1 $ \j -> f $ ixList i j) . getEnv 112 | 113 | ixList :: Index as a -> i a b -> IxList i as b 114 | ixList = \case 115 | IZ -> IxHead 116 | IS x -> IxTail . ixList x 117 | 118 | -------------------------------------------------------------------------------- /src/Data/Type/Remove.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE FunctionalDependencies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE LambdaCase #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE DataKinds #-} 14 | {-# LANGUAGE PolyKinds #-} 15 | {-# LANGUAGE GADTs #-} 16 | ----------------------------------------------------------------------------- 17 | -- | 18 | -- Module : Data.Type.Remove 19 | -- Copyright : Copyright (C) 2015 Kyle Carter 20 | -- License : BSD3 21 | -- 22 | -- Maintainer : Kyle Carter 23 | -- Stability : experimental 24 | -- Portability : RankNTypes 25 | -- 26 | -- A @singleton@-esque type for representing the removal of an element from a type level list. 27 | -- 28 | ----------------------------------------------------------------------------- 29 | 30 | module Data.Type.Remove where 31 | 32 | -- import Data.Type.Quantifier 33 | import Type.Class.Higher 34 | import Type.Class.Known 35 | import Type.Class.Witness 36 | import Type.Family.Constraint 37 | import Type.Family.List 38 | import Type.Family.Nat 39 | import Data.Type.Length 40 | import Data.Type.Index 41 | import Data.Type.Subset 42 | import Data.Type.Product 43 | import Data.Type.Sum 44 | import Control.Arrow (second,right) 45 | 46 | data Remove :: [k] -> k -> [k] -> * where 47 | RZ :: Remove (a :< as) a as 48 | RS :: !(Remove as a bs) 49 | -> Remove (b :< as) a (b :< bs) 50 | 51 | deriving instance Eq (Remove as a bs) 52 | deriving instance Ord (Remove as a bs) 53 | deriving instance Show (Remove as a bs) 54 | 55 | instance Eq1 (Remove as a) 56 | instance Ord1 (Remove as a) 57 | instance Show1 (Remove as a) 58 | 59 | instance Eq2 (Remove as) 60 | instance Ord2 (Remove as) 61 | instance Show2 (Remove as) 62 | 63 | instance Eq3 Remove 64 | instance Ord3 Remove 65 | instance Show3 Remove 66 | 67 | instance Read3 Remove where 68 | readsPrec3 d = readParen (d > 10) $ \s0 -> 69 | [ (Some3 RZ,s1) 70 | | ("RZ",s1) <- lex s0 71 | ] ++ 72 | [ (i >>--- Some3 . RS,s2) 73 | | ("RS",s1) <- lex s0 74 | , (i,s2) <- readsPrec3 11 s1 75 | ] 76 | 77 | instance TestEquality (Remove as a) where 78 | testEquality = \case 79 | RZ -> \case 80 | RZ -> qed 81 | _ -> Nothing 82 | RS x -> \case 83 | RS y -> x =?= y //? qed 84 | _ -> Nothing 85 | 86 | remLen :: Remove as a bs -> S (Len bs) :~: Len as 87 | remLen = \case 88 | RZ -> Refl 89 | RS r -> remLen r // Refl 90 | 91 | elimRemove :: (forall xs. p (a :< xs) a xs) 92 | -> (forall x xs ys. Remove xs a ys -> p xs a ys -> p (x :< xs) a (x :< ys)) 93 | -> Remove as a bs 94 | -> p as a bs 95 | elimRemove z s = \case 96 | RZ -> z 97 | RS r -> s r $ elimRemove z s r 98 | 99 | remIx :: Remove as a bs -> Index as a 100 | remIx = \case 101 | RZ -> IZ 102 | RS r -> IS $ remIx r 103 | 104 | remSub :: Length bs -> Remove as a bs -> Subset as bs 105 | remSub = \case 106 | LZ -> \case 107 | RZ -> Ø 108 | LS l -> \case 109 | RZ -> IS IZ :< map1 (IS . IS) subRefl \\ l 110 | RS r -> IZ :< map1 IS (remSub l r) 111 | 112 | ixRem :: Index as a -> Some (Remove as a) 113 | ixRem = \case 114 | IZ -> Some RZ 115 | IS x -> ixRem x >>- Some . RS 116 | 117 | remProd :: Remove as a bs -> Prod f as -> (f a,Prod f bs) 118 | remProd = \case 119 | RZ -> (,) <$> head' <*> tail' 120 | RS r -> \(a :< as) -> second (a :<) $ remProd r as 121 | 122 | remSum :: Remove as a bs -> Sum f as -> Either (f a) (Sum f bs) 123 | remSum = \case 124 | RZ -> \case 125 | InL a -> Left a 126 | InR b -> Right b 127 | RS r -> \case 128 | InL a -> Right $ InL a 129 | InR b -> right InR $ remSum r b 130 | 131 | class Without (as :: [k]) (a :: k) (bs :: [k]) | as a -> bs where 132 | without :: Remove as a bs 133 | 134 | instance {-# OVERLAPPING #-} (as ~ bs) => Without (a :< as) a bs where 135 | without = RZ 136 | 137 | instance {-# OVERLAPPABLE #-} (cs ~ (b :< bs), Without as a bs) => Without (b :< as) a cs where 138 | without = RS without 139 | 140 | instance Witness ØC (Without as a bs) (Remove as a bs) where 141 | (\\) r = \case 142 | RZ -> r 143 | RS x -> r \\ x 144 | 145 | instance (Without as a bs) => Known (Remove as a) bs where 146 | type KnownC (Remove as a) bs = Without as a bs 147 | known = without 148 | 149 | -------------------------------------------------------------------------------- /src/Data/Type/Difference.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE FunctionalDependencies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE LambdaCase #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE DataKinds #-} 14 | {-# LANGUAGE PolyKinds #-} 15 | {-# LANGUAGE GADTs #-} 16 | ----------------------------------------------------------------------------- 17 | -- | 18 | -- Module : Data.Type.Difference 19 | -- Copyright : Copyright (C) 2015 Kyle Carter 20 | -- License : BSD3 21 | -- 22 | -- Maintainer : Kyle Carter 23 | -- Stability : experimental 24 | -- Portability : RankNTypes 25 | -- 26 | -- A @singleton@-esque type for representing the removal of a subset of a type level list. 27 | -- 28 | ----------------------------------------------------------------------------- 29 | 30 | module Data.Type.Difference where 31 | 32 | -- import Data.Type.Quantifier 33 | import Type.Class.Known 34 | import Type.Class.Witness 35 | import Type.Family.Constraint 36 | import Type.Family.List 37 | import Data.Type.Length 38 | import Data.Type.Subset 39 | import Data.Type.Remove 40 | import Data.Type.Sum 41 | import Control.Arrow (first,left) 42 | 43 | data Difference :: [k] -> [k] -> [k] -> * where 44 | ØD :: Difference as Ø as 45 | (:-) :: !(Remove bs a cs) 46 | -> !(Difference cs as ds) 47 | -> Difference bs (a :< as) ds 48 | infixr 5 :- 49 | 50 | diffLen :: Difference as bs cs -> Length bs 51 | diffLen = \case 52 | ØD -> LZ 53 | _ :- d -> LS $ diffLen d 54 | 55 | {- 56 | deriving instance Eq (Difference as bs cs) 57 | deriving instance Ord (Difference as bs cs) 58 | deriving instance Show (Difference as bs cs) 59 | 60 | instance Eq1 (Difference as bs) 61 | instance Ord1 (Difference as bs) 62 | instance Show1 (Difference as bs) 63 | 64 | instance Eq2 (Difference as) 65 | instance Ord2 (Difference as) 66 | instance Show2 (Difference as) 67 | 68 | instance Eq3 Difference 69 | instance Ord3 Difference 70 | instance Show3 Difference 71 | -} 72 | 73 | {- 74 | instance Read3 Remove where 75 | readsPrec3 d = readParen (d > 10) $ \s0 -> 76 | [ (Some3 RZ,s1) 77 | | ("RZ",s1) <- lex s0 78 | ] ++ 79 | [ (i >>--- Some3 . RS,s2) 80 | | ("RS",s1) <- lex s0 81 | , (i,s2) <- readsPrec3 11 s1 82 | ] 83 | -} 84 | 85 | instance TestEquality (Difference as bs) where 86 | testEquality = \case 87 | ØD -> \case 88 | ØD -> qed 89 | r1 :- d1 -> \case 90 | r2 :- d2 -> r1 =?= r2 //? d1 =?= d2 //? qed 91 | 92 | elimDifference :: (forall xs. p xs Ø xs) 93 | -> (forall x ws xs ys zs. Remove xs x ys -> Difference ys ws zs -> p ys ws zs -> p xs (x :< ws) zs) 94 | -> Difference as bs cs 95 | -> p as bs cs 96 | elimDifference n c = \case 97 | ØD -> n 98 | r :- d -> c r d $ elimDifference n c d 99 | 100 | {- 101 | diffSub :: Known Length as => Difference as bs cs -> Subset as bs 102 | diffSub = \case 103 | ØD -> Ø 104 | (r :: Remove as a ds) :- (d :: Difference ds es cs) -> x :< s 105 | where 106 | x :: Index as a 107 | x = remIx r 108 | s :: Subset as es 109 | s = subTrans s2 s1 110 | s1 :: Subset ds es 111 | s1 = diffSub d 112 | s2 :: Subset as ds 113 | s2 = remSub l r 114 | l :: Length ds 115 | l = _ 116 | -} 117 | 118 | {- 119 | subDiff :: Subset as bs -> Some (Difference as bs) 120 | subDiff = \case 121 | Ø -> Some ØD 122 | x :< s -> ixRem x >>- \r -> subDiff s >>- \d -> Some $ r :- _ d 123 | -} 124 | 125 | diffProd :: Difference as bs cs -> Prod f as -> (Prod f bs,Prod f cs) 126 | diffProd = \case 127 | ØD -> (,) Ø 128 | r :- d -> \as -> let 129 | (a,as') = remProd r as 130 | in first (a :<) $ diffProd d as' 131 | 132 | diffSum :: Difference as bs cs -> Sum f as -> Either (Sum f bs) (Sum f cs) 133 | diffSum = \case 134 | ØD -> Right 135 | r :- d -> \as -> case remSum r as of 136 | Left a -> Left $ InL a 137 | Right bs -> left InR $ diffSum d bs 138 | 139 | class WithoutAll (as :: [k]) (bs :: [k]) (cs :: [k]) | as bs -> cs where 140 | withoutAll :: Difference as bs cs 141 | 142 | instance (cs ~ as) => WithoutAll as Ø cs where 143 | withoutAll = ØD 144 | 145 | instance (Without as b cs, WithoutAll cs bs ds) => WithoutAll as (b :< bs) ds where 146 | withoutAll = without :- withoutAll 147 | 148 | instance Witness ØC (WithoutAll as bs cs) (Difference as bs cs) where 149 | (\\) r = \case 150 | ØD -> r 151 | x :- d -> r \\ x \\ d 152 | 153 | instance WithoutAll as bs cs => Known (Difference as bs) cs where 154 | type KnownC (Difference as bs) cs = WithoutAll as bs cs 155 | known = withoutAll 156 | 157 | -------------------------------------------------------------------------------- /src/Data/Type/Sum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE LambdaCase #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE DataKinds #-} 14 | {-# LANGUAGE PolyKinds #-} 15 | {-# LANGUAGE GADTs #-} 16 | ----------------------------------------------------------------------------- 17 | -- | 18 | -- Module : Data.Type.Sum 19 | -- Copyright : Copyright (C) 2015 Kyle Carter 20 | -- License : BSD3 21 | -- 22 | -- Maintainer : Kyle Carter 23 | -- Stability : experimental 24 | -- Portability : RankNTypes 25 | -- 26 | -- 'Sum' is a type combinators for representing disjoint sums of 27 | -- indices @(as :: [k])@ of a single functor @(f :: k -> *). 28 | -- Contrast to the many-functors-one-index 'FSum' 29 | -- 30 | ----------------------------------------------------------------------------- 31 | 32 | module Data.Type.Sum where 33 | 34 | import Data.Type.Index 35 | -- import Data.Type.Quantifier 36 | 37 | import Type.Class.Higher 38 | import Type.Class.Witness 39 | 40 | import Type.Family.List 41 | 42 | data Sum (f :: k -> *) :: [k] -> * where 43 | InL :: !(f a) -> Sum f (a :< as) 44 | InR :: !(Sum f as) -> Sum f (a :< as) 45 | 46 | deriving instance ListC (Eq <$> f <$> as) => Eq (Sum f as) 47 | deriving instance 48 | ( ListC (Eq <$> f <$> as) 49 | , ListC (Ord <$> f <$> as) 50 | ) => Ord (Sum f as) 51 | deriving instance ListC (Show <$> f <$> as) => Show (Sum f as) 52 | 53 | instance Eq1 f => Eq1 (Sum f) where 54 | eq1 = \case 55 | InL a -> \case 56 | InL b -> a =#= b 57 | _ -> False 58 | InR a -> \case 59 | InR b -> a =#= b 60 | _ -> False 61 | 62 | instance Ord1 f => Ord1 (Sum f) where 63 | compare1 = \case 64 | InL a -> \case 65 | InL b -> compare1 a b 66 | _ -> LT 67 | InR a -> \case 68 | InR b -> compare1 a b 69 | _ -> GT 70 | 71 | instance Show1 f => Show1 (Sum f) where 72 | showsPrec1 d = showParen (d > 10) . \case 73 | InL a -> showString "InL " 74 | . showsPrec1 11 a 75 | InR b -> showString "InR " 76 | . showsPrec1 11 b 77 | 78 | instance Read1 f => Read1 (Sum f) where 79 | readsPrec1 d = readParen (d > 10) $ \s0 -> 80 | [ (a >>- Some . InL,s2) 81 | | ("InL",s1) <- lex s0 82 | , (a,s2) <- readsPrec1 11 s1 83 | ] ++ 84 | [ (a >>- Some . InR,s2) 85 | | ("InR",s1) <- lex s0 86 | , (a,s2) <- readsPrec1 11 s1 87 | ] 88 | 89 | -- | There are no possible values of the type @Sum f Ø@. 90 | nilSum :: Sum f Ø -> Void 91 | nilSum = impossible 92 | 93 | decomp :: Sum f (a :< as) -> Either (f a) (Sum f as) 94 | decomp = \case 95 | InL a -> Left a 96 | InR s -> Right s 97 | 98 | injectSum :: Index as a -> f a -> Sum f as 99 | injectSum = \case 100 | IZ -> InL 101 | IS x -> InR . injectSum x 102 | 103 | inj :: (a ∈ as) => f a -> Sum f as 104 | inj = injectSum elemIndex 105 | 106 | prj :: (a ∈ as) => Sum f as -> Maybe (f a) 107 | prj = index elemIndex 108 | 109 | index :: Index as a -> Sum f as -> Maybe (f a) 110 | index = \case 111 | IZ -> \case 112 | InL a -> Just a 113 | _ -> Nothing 114 | IS x -> \case 115 | InR s -> index x s 116 | _ -> Nothing 117 | 118 | elimSum :: (forall x xs. f x -> p (x :< xs)) 119 | -> (forall x xs. Index as x -> p xs -> p (x :< xs)) 120 | -> Sum f as 121 | -> p as 122 | elimSum t n = \case 123 | InL a -> t a 124 | InR s -> n IZ $ elimSum t (n . IS) s 125 | 126 | -- instances {{{ 127 | 128 | instance Functor1 Sum where 129 | map1 f = \case 130 | InL a -> InL $ f a 131 | InR s -> InR $ map1 f s 132 | 133 | instance IxFunctor1 Index Sum where 134 | imap1 f = \case 135 | InL a -> InL $ f IZ a 136 | InR s -> InR $ imap1 (f . IS) s 137 | 138 | instance Foldable1 Sum where 139 | foldMap1 f = \case 140 | InL a -> f a 141 | InR s -> foldMap1 f s 142 | 143 | instance IxFoldable1 Index Sum where 144 | ifoldMap1 f = \case 145 | InL a -> f IZ a 146 | InR s -> ifoldMap1 (f . IS) s 147 | 148 | instance Traversable1 Sum where 149 | traverse1 f = \case 150 | InL a -> InL <$> f a 151 | InR s -> InR <$> traverse1 f s 152 | 153 | instance IxTraversable1 Index Sum where 154 | itraverse1 f = \case 155 | InL a -> InL <$> f IZ a 156 | InR s -> InR <$> itraverse1 (f . IS) s 157 | 158 | instance Witness p q (f a) => Witness p q (Sum f '[a]) where 159 | type WitnessC p q (Sum f '[a]) = Witness p q (f a) 160 | (\\) r = \case 161 | InL a -> r \\ a 162 | _ -> error "impossible type" 163 | 164 | instance (Witness p q (f a), Witness p q (Sum f (b :< as))) => Witness p q (Sum f (a :< b :< as)) where 165 | type WitnessC p q (Sum f (a :< b :< as)) = (Witness p q (f a), Witness p q (Sum f (b :< as))) 166 | (\\) r = \case 167 | InL a -> r \\ a 168 | InR s -> r \\ s 169 | 170 | -- }}} 171 | 172 | -------------------------------------------------------------------------------- /src/Data/Type/Fin/Indexed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableSuperClasses #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | {-# LANGUAGE ConstraintKinds #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE LambdaCase #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE KindSignatures #-} 15 | {-# LANGUAGE DataKinds #-} 16 | {-# LANGUAGE PolyKinds #-} 17 | {-# LANGUAGE GADTs #-} 18 | ----------------------------------------------------------------------------- 19 | -- | 20 | -- Module : Data.Type.Fin.Indexed 21 | -- Copyright : Copyright (C) 2015 Kyle Carter 22 | -- License : BSD3 23 | -- 24 | -- Maintainer : Kyle Carter 25 | -- Stability : experimental 26 | -- Portability : RankNTypes 27 | -- 28 | -- A @singleton@-esque type for representing members of finite sets, 29 | -- indexed by its Nat value. 30 | -- 31 | ----------------------------------------------------------------------------- 32 | 33 | module Data.Type.Fin.Indexed where 34 | 35 | import Data.Type.Nat 36 | import Type.Class.Higher 37 | -- import Type.Class.Known 38 | import Type.Class.Witness 39 | import Type.Family.Constraint 40 | import Type.Family.Nat 41 | -- import Data.Type.Quantifier 42 | 43 | data IFin :: N -> N -> * where 44 | IFZ :: IFin (S x) Z 45 | IFS :: !(IFin x y) -> IFin (S x) (S y) 46 | 47 | deriving instance Eq (IFin x y) 48 | deriving instance Ord (IFin x y) 49 | deriving instance Show (IFin x y) 50 | 51 | instance Eq1 (IFin x) 52 | instance Ord1 (IFin x) 53 | instance Show1 (IFin x) 54 | 55 | instance Eq2 IFin 56 | instance Ord2 IFin 57 | instance Show2 IFin 58 | 59 | instance Read2 IFin where 60 | readsPrec2 d = readParen (d > 10) $ \s0 -> 61 | [ (Some2 IFZ,s1) 62 | | ("IFZ",s1) <- lex s0 63 | ] ++ 64 | [ (n >>-- Some2 . IFS,s2) 65 | | ("IFS",s1) <- lex s0 66 | , (n,s2) <- readsPrec2 11 s1 67 | ] 68 | 69 | class LTC x y => LessEq (x :: N) (y :: N) where 70 | type LTC x y :: Constraint 71 | liftIFin :: IFin x z -> IFin y z 72 | 73 | instance LessEq Z y where 74 | type LTC Z y = ØC 75 | liftIFin = absurd . ifinZ 76 | 77 | instance (y ~ S (Pred y), LessEq x (Pred y)) => LessEq (S x) y where 78 | type LTC (S x) y = (y ~ S (Pred y), LessEq x (Pred y)) 79 | liftIFin = \case 80 | IFZ -> IFZ 81 | IFS x -> IFS $ liftIFin x 82 | 83 | ifinZ :: IFin Z x -> Void 84 | ifinZ = impossible 85 | 86 | weaken :: IFin x y -> IFin (S x) y 87 | weaken = \case 88 | IFZ -> IFZ 89 | IFS n -> IFS $ weaken n 90 | 91 | ifinNat :: IFin x y -> Nat y 92 | ifinNat = \case 93 | IFZ -> Z_ 94 | IFS n -> S_ $ ifinNat n 95 | 96 | ifinVal :: IFin x y -> Int 97 | ifinVal = natVal . ifinNat 98 | 99 | onIFinPred :: (forall x. IFin m x -> IFin n x) -> IFin (S m) y -> IFin (S n) y 100 | onIFinPred f = \case 101 | IFZ -> IFZ 102 | IFS m -> IFS $ f m 103 | 104 | {- 105 | -- | Map a finite set to a lower finite set without 106 | -- one of its members. 107 | without :: IFin n x -> IFin n y -> Maybe (IFin (Pred n)) 108 | without = \case 109 | FZ -> \case 110 | FZ -> Nothing 111 | FS y -> Just y 112 | FS x -> \case 113 | FZ -> Just FZ \\ x 114 | FS y -> FS <$> without x y \\ x 115 | -} 116 | 117 | -- | An @IFin x y@ is a 'Witness' that @x >= 1@. 118 | -- 119 | -- That is, @'Pred' x@ is well defined. 120 | instance (x' ~ Pred x) => Witness ØC (S x' ~ x) (IFin x y) where 121 | type WitnessC ØC (S x' ~ x) (IFin x y) = (x' ~ Pred x) 122 | (\\) r = \case 123 | IFZ -> r 124 | IFS _ -> r 125 | 126 | {- 127 | elimFin :: (forall x. p (S x)) 128 | -> (forall x. Fin x -> p x -> p (S x)) 129 | -> Fin n -> p n 130 | elimFin z s = \case 131 | FZ -> z 132 | FS n -> s n $ elimFin z s n 133 | 134 | -- | Gives the list of all members of the finite set of size @n@. 135 | fins :: Nat n -> [Fin n] 136 | fins = \case 137 | Z_ -> [] 138 | S_ x -> FZ : map FS (fins x) 139 | 140 | fin :: Fin n -> Int 141 | fin = \case 142 | FZ -> 0 143 | FS x -> succ $ fin x 144 | 145 | -- | There are no members of @Fin Z@. 146 | finZ :: Fin Z -> Void 147 | finZ = impossible 148 | 149 | weaken :: Fin n -> Fin (S n) 150 | weaken = \case 151 | FZ -> FZ 152 | FS n -> FS $ weaken n 153 | 154 | -- | Map a finite set to a lower finite set without 155 | -- one of its members. 156 | without :: Fin n -> Fin n -> Maybe (Fin (Pred n)) 157 | without = \case 158 | FZ -> \case 159 | FZ -> Nothing 160 | FS y -> Just y 161 | FS x -> \case 162 | FZ -> Just FZ \\ x 163 | FS y -> FS <$> without x y \\ x 164 | 165 | -- | Take a 'Fin' to an existentially quantified 'Nat'. 166 | finNat :: Fin x -> Some Nat 167 | finNat = \case 168 | FZ -> Some Z_ 169 | FS x -> withSome (Some . S_) $ finNat x 170 | 171 | -- | A @Fin n@ is a 'Witness' that @n >= 1@. 172 | -- 173 | -- That is, @'Pred' n@ is well defined. 174 | instance (n' ~ Pred n) => Witness ØC (S n' ~ n) (Fin n) where 175 | type WitnessC ØC (S n' ~ n) (Fin n) = (n' ~ Pred n) 176 | (\\) r = \case 177 | FZ -> r 178 | FS _ -> r 179 | -} 180 | 181 | -------------------------------------------------------------------------------- /src/Type/Family/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilyDependencies #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE FunctionalDependencies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE LambdaCase #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE DataKinds #-} 14 | {-# LANGUAGE PolyKinds #-} 15 | {-# LANGUAGE GADTs #-} 16 | ----------------------------------------------------------------------------- 17 | -- | 18 | -- Module : Type.Family.List 19 | -- Copyright : Copyright (C) 2015 Kyle Carter 20 | -- License : BSD3 21 | -- 22 | -- Maintainer : Kyle Carter 23 | -- Stability : experimental 24 | -- Portability : RankNTypes 25 | -- 26 | -- Convenient aliases and type families for working with 27 | -- type-level lists. 28 | ---------------------------------------------------------------------------- 29 | 30 | module Type.Family.List where 31 | 32 | import Type.Family.Constraint 33 | import Type.Family.Monoid 34 | import Type.Family.Tuple hiding (type (<$>),type (<*>),type (<&>)) 35 | import Type.Class.Witness 36 | 37 | type Ø = '[] 38 | type (:<) = '(:) 39 | infixr 5 :< 40 | 41 | -- | Type-level singleton list. 42 | type Only a = '[a] 43 | 44 | -- Null,Append,Concat {{{ 45 | 46 | type family Null (as :: [k]) :: Bool where 47 | Null Ø = True 48 | Null (a :< as) = False 49 | 50 | nullCong :: (a ~ b) :- (Null a ~ Null b) 51 | nullCong = Sub Wit 52 | 53 | nilNotCons :: (Ø ~ (a :< as)) :- Fail 54 | nilNotCons = nullCong 55 | 56 | -- | Appends two type-level lists. 57 | type family (as :: [k]) ++ (bs :: [k]) :: [k] where 58 | Ø ++ bs = bs 59 | (a :< as) ++ bs = a :< (as ++ bs) 60 | infixr 5 ++ 61 | 62 | appendCong :: (a ~ b,c ~ d) :- ((a ++ c) ~ (b ++ d)) 63 | appendCong = Sub Wit 64 | 65 | type family Concat (ls :: [[k]]) :: [k] where 66 | Concat Ø = Ø 67 | Concat (l :< ls) = l ++ Concat ls 68 | 69 | concatCong :: (as ~ bs) :- (Concat as ~ Concat bs) 70 | concatCong = Sub Wit 71 | 72 | -- }}} 73 | 74 | -- Snoc,Reverse {{{ 75 | 76 | -- | Type-level list snoc. 77 | type family (as :: [k]) >: (a :: k) :: [k] where 78 | Ø >: a = a :< Ø 79 | (b :< as) >: a = b :< (as >: a) 80 | infixl 6 >: 81 | 82 | snocCong :: (as ~ bs,a ~ b) :- ((as >: a) ~ (bs >: b)) 83 | snocCong = Sub Wit 84 | 85 | type family Reverse (as :: [k]) :: [k] where 86 | Reverse Ø = Ø 87 | Reverse (a :< as) = Reverse as >: a 88 | 89 | reverseCong :: (as ~ bs) :- (Reverse as ~ Reverse bs) 90 | reverseCong = Sub Wit 91 | 92 | -- }}} 93 | 94 | -- Head,Tail,Init,Last {{{ 95 | 96 | type family HeadM (as :: [k]) :: Maybe k where 97 | HeadM Ø = Nothing 98 | HeadM (a :< as) = Just a 99 | 100 | type family Head (as :: [k]) :: k where 101 | Head (a :< as) = a 102 | 103 | type family TailM (as :: [k]) :: Maybe [k] where 104 | TailM Ø = Nothing 105 | TailM (a :< as) = Just as 106 | 107 | type family Tail (as :: [k]) :: [k] where 108 | Tail (a :< as) = as 109 | 110 | type family InitM (as :: [k]) :: Maybe [k] where 111 | InitM Ø = Nothing 112 | InitM (a :< as) = Just (Init' a as) 113 | 114 | type family Init (as :: [k]) :: [k] where 115 | Init (a :< as) = Init' a as 116 | 117 | type family Init' (a :: k) (as :: [k]) :: [k] where 118 | Init' a Ø = Ø 119 | Init' a (b :< as) = a :< Init' b as 120 | 121 | initCong :: (a ~ b,as ~ bs) :- (Init' a as ~ Init' b bs) 122 | initCong = Sub Wit 123 | 124 | type family LastM (as :: [k]) :: Maybe k where 125 | LastM Ø = Nothing 126 | LastM (a :< as) = Just (Last' a as) 127 | 128 | type family Last (as :: [k]) :: k where 129 | Last (a :< as) = Last' a as 130 | 131 | type family Last' (a :: k) (as :: [k]) :: k where 132 | Last' a Ø = a 133 | Last' a (b :< as) = Last' b as 134 | 135 | lastCong :: (a ~ b,as ~ bs) :- (Last' a as ~ Last' b bs) 136 | lastCong = Sub Wit 137 | 138 | -- }}} 139 | 140 | -- | Takes a type-level list of 'Constraint's to a single 141 | -- 'Constraint', where @ListC cs@ holds iff all elements 142 | -- of @cs@ hold. 143 | type family ListC (cs :: [Constraint]) = (c :: Constraint) | c -> cs where 144 | ListC Ø = ØC 145 | ListC (c :< cs) = (c, ListC cs) 146 | 147 | -- Map et al {{{ 148 | 149 | -- | Map an @(f :: k -> l)@ over a type-level list @(as :: [k])@, 150 | -- giving a list @(bs :: [l])@. 151 | type family (f :: k -> l) <$> (a :: [k]) :: [l] where 152 | f <$> Ø = Ø 153 | f <$> (a :< as) = f a :< (f <$> as) 154 | infixr 4 <$> 155 | 156 | listMapCong :: (f ~ g,as ~ bs) :- ((f <$> as) ~ (g <$> bs)) 157 | listMapCong = Sub Wit 158 | 159 | -- | Map a list of @(fs :: [k -> l])@ over a single @(a :: k)@, 160 | -- giving a list @(bs :: [l])@. 161 | type family (f :: [k -> l]) <&> (a :: k) :: [l] where 162 | Ø <&> a = Ø 163 | (f :< fs) <&> a = f a :< (fs <&> a) 164 | infixl 5 <&> 165 | 166 | type family (f :: [k -> l]) <*> (a :: [k]) :: [l] where 167 | fs <*> Ø = Ø 168 | fs <*> (a :< as) = (fs <&> a) ++ (fs <*> as) 169 | infixr 4 <*> 170 | 171 | -- }}} 172 | 173 | -- Tuples {{{ 174 | 175 | type family Fsts (ps :: [(k,l)]) :: [k] where 176 | Fsts Ø = Ø 177 | Fsts (p :< ps) = Fst p :< Fsts ps 178 | 179 | type family Snds (ps :: [(k,l)]) :: [l] where 180 | Snds Ø = Ø 181 | Snds (p :< ps) = Snd p :< Snds ps 182 | 183 | type family Zip (as :: [k]) (bs :: [l]) = (cs :: [(k,l)]) | cs -> as bs where 184 | Zip Ø Ø = Ø 185 | Zip (a :< as) (b :< bs) = a#b :< Zip as bs 186 | 187 | type family Fsts3 (ps :: [(k,l,m)]) :: [k] where 188 | Fsts3 Ø = Ø 189 | Fsts3 (p :< ps) = Fst3 p :< Fsts3 ps 190 | 191 | type family Snds3 (ps :: [(k,l,m)]) :: [l] where 192 | Snds3 Ø = Ø 193 | Snds3 (p :< ps) = Snd3 p :< Snds3 ps 194 | 195 | type family Thds3 (ps :: [(k,l,m)]) :: [m] where 196 | Thds3 Ø = Ø 197 | Thds3 (p :< ps) = Thd3 p :< Thds3 ps 198 | 199 | -- }}} 200 | 201 | type instance Mempty = Ø 202 | type instance a <> b = a ++ b 203 | 204 | -------------------------------------------------------------------------------- /src/Data/Type/Product/Lifted.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE KindSignatures #-} 11 | {-# LANGUAGE DataKinds #-} 12 | {-# LANGUAGE PolyKinds #-} 13 | {-# LANGUAGE GADTs #-} 14 | ----------------------------------------------------------------------------- 15 | -- | 16 | -- Module : Data.Type.Product.Lifted 17 | -- Copyright : Copyright (C) 2015 Kyle Carter 18 | -- License : BSD3 19 | -- 20 | -- Maintainer : Kyle Carter 21 | -- Stability : experimental 22 | -- Portability : RankNTypes 23 | -- 24 | -- Type combinators for type-level lists, 25 | -- where we have many functors with a single index. 26 | -- 27 | ----------------------------------------------------------------------------- 28 | 29 | module Data.Type.Product.Lifted where 30 | 31 | import Data.Type.Index 32 | import Type.Class.Known 33 | import Type.Class.Witness 34 | import Type.Family.Constraint 35 | import Type.Family.List 36 | 37 | import Data.Monoid ((<>)) 38 | 39 | data FProd (fs :: [k -> *]) :: k -> * where 40 | ØF :: FProd Ø a 41 | (:<<) :: !(f a) -> !(FProd fs a) -> FProd (f :< fs) a 42 | infixr 5 :<< 43 | 44 | -- | Construct a two element FProd. 45 | -- Since the precedence of (:>>) is higher than (:<<), 46 | -- we can conveniently write lists like: 47 | -- 48 | -- >>> a :<< b :>> c 49 | -- 50 | -- Which is identical to: 51 | -- 52 | -- >>> a :<< b :<< c :<< Ø 53 | -- 54 | pattern (:>>) :: (f :: k -> *) (a :: k) -> (g :: k -> *) a -> FProd '[f,g] a 55 | pattern a :>> b = a :<< b :<< ØF 56 | infix 6 :>> 57 | 58 | -- | Build a singleton FProd. 59 | onlyF :: f a -> FProd '[f] a 60 | onlyF = (:<< ØF) 61 | 62 | -- | snoc function. insert an element at the end of the FProd. 63 | (>>:) :: FProd fs a -> f a -> FProd (fs >: f) a 64 | (>>:) = \case 65 | ØF -> onlyF 66 | b :<< as -> (b :<<) . (as >>:) 67 | infixl 6 >>: 68 | 69 | headF :: FProd (f :< fs) a -> f a 70 | headF (a :<< _) = a 71 | 72 | tailF :: FProd (f :< fs) a -> FProd fs a 73 | tailF (_ :<< as) = as 74 | 75 | -- | Get all but the last element of a non-empty FProd. 76 | initF :: FProd (f :< fs) a -> FProd (Init' f fs) a 77 | initF (a :<< as) = case as of 78 | ØF -> ØF 79 | (:<<){} -> a :<< initF as 80 | 81 | -- | Get the last element of a non-empty FProd. 82 | lastF :: FProd (f :< fs) a -> Last' f fs a 83 | lastF (a :<< as) = case as of 84 | ØF -> a 85 | (:<<){} -> lastF as 86 | 87 | -- | Reverse the elements of an FProd. 88 | reverseF :: FProd fs a -> FProd (Reverse fs) a 89 | reverseF = \case 90 | ØF -> ØF 91 | a :<< as -> reverseF as >>: a 92 | 93 | -- | Append two FProds. 94 | appendF :: FProd fs a -> FProd gs a -> FProd (fs ++ gs) a 95 | appendF = \case 96 | ØF -> id 97 | a :<< as -> (a :<<) . appendF as 98 | 99 | -- | Map over the head of a non-empty FProd. 100 | onHeadF :: (f a -> g a) -> FProd (f :< fs) a -> FProd (g :< fs) a 101 | onHeadF f (a :<< as) = f a :<< as 102 | 103 | -- | Map over the tail of a non-empty FProd. 104 | onTailF :: (FProd fs a -> FProd gs a) -> FProd (f :< fs) a -> FProd (f :< gs) a 105 | onTailF f (a :<< as) = a :<< f as 106 | 107 | uncurryF :: (f a -> FProd fs a -> r) -> FProd (f :< fs) a -> r 108 | uncurryF f (a :<< as) = f a as 109 | 110 | curryF :: (l ~ (f :< fs)) => (FProd l a -> r) -> f a -> FProd fs a -> r 111 | curryF f a as = f $ a :<< as 112 | 113 | indexF :: Index fs f -> FProd fs a -> f a 114 | indexF = \case 115 | IZ -> headF 116 | IS x -> indexF x . tailF 117 | 118 | -- | If all @f@ in @fs@ are @Functor@s, then @FProd fs@ is a @Functor@. 119 | instance ListC (Functor <$> fs) => Functor (FProd fs) where 120 | fmap f = \case 121 | ØF -> ØF 122 | a :<< as -> fmap f a :<< fmap f as 123 | 124 | -- | If all @f@ in @fs@ are @Foldable@s, then @FProd fs@ is a @Foldable@. 125 | instance ListC (Foldable <$> fs) => Foldable (FProd fs) where 126 | foldMap f = \case 127 | ØF -> mempty 128 | a :<< as -> foldMap f a <> foldMap f as 129 | 130 | -- | If all @f@ in @fs@ are @Traversable@s, then @FProd fs@ is a @Traversable@. 131 | instance 132 | ( ListC (Functor <$> fs) 133 | , ListC (Foldable <$> fs) 134 | , ListC (Traversable <$> fs) 135 | ) => Traversable (FProd fs) where 136 | traverse f = \case 137 | ØF -> pure ØF 138 | a :<< as -> (:<<) <$> traverse f a <*> traverse f as 139 | 140 | -- | Map over all elements of an FProd with access to the element's index. 141 | imapF :: (forall f. Index fs f -> f a -> f b) 142 | -> FProd fs a -> FProd fs b 143 | imapF f = \case 144 | ØF -> ØF 145 | a :<< as -> f IZ a :<< imapF (f . IS) as 146 | 147 | -- | Fold over all elements of an FProd with access to the element's index. 148 | ifoldMapF :: Monoid m 149 | => (forall f. Index fs f -> f a -> m) 150 | -> FProd fs a -> m 151 | ifoldMapF f = \case 152 | ØF -> mempty 153 | a :<< as -> f IZ a <> ifoldMapF (f . IS) as 154 | 155 | -- | Traverse over all elements of an FProd with access to the element's index. 156 | itraverseF :: Applicative g 157 | => (forall f. Index fs f -> f a -> g (f b)) 158 | -> FProd fs a -> g (FProd fs b) 159 | itraverseF f = \case 160 | ØF -> pure ØF 161 | a :<< as -> (:<<) <$> f IZ a <*> itraverseF (f . IS) as 162 | 163 | instance Known (FProd Ø) a where 164 | known = ØF 165 | 166 | instance (Known f a, Known (FProd fs) a) => Known (FProd (f :< fs)) a where 167 | type KnownC (FProd (f :< fs)) a = (Known f a, Known (FProd fs) a) 168 | known = known :<< known 169 | 170 | -- | An empty FProd is a no-op Witness. 171 | instance Witness ØC ØC (FProd Ø a) where 172 | r \\ _ = r 173 | 174 | -- | A non-empty FProd is a Witness if both its head and tail are Witnesses. 175 | instance (Witness p q (f a), Witness s t (FProd fs a)) => Witness (p,s) (q,t) (FProd (f :< fs) a) where 176 | type WitnessC (p,s) (q,t) (FProd (f :< fs) a) = (Witness p q (f a), Witness s t (FProd fs a)) 177 | r \\ (a :<< as) = r \\ a \\ as 178 | 179 | -------------------------------------------------------------------------------- /src/Data/Type/Disjunction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE GADTs #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Type.Disjunction 18 | -- Copyright : Copyright (C) 2015 Kyle Carter 19 | -- License : BSD3 20 | -- 21 | -- Maintainer : Kyle Carter 22 | -- Stability : experimental 23 | -- Portability : RankNTypes 24 | -- 25 | -- Two type combinators for working with disjunctions: 26 | -- A /branch/ combinator '(:|:)', and a /choice/ combinator '(:+:)'. 27 | -- 28 | -- These are analogous to '(|||)' and '(+++)' from 'Control.Arrow', 29 | -- respectively. 30 | -- 31 | ----------------------------------------------------------------------------- 32 | 33 | module Data.Type.Disjunction where 34 | 35 | -- import Data.Type.Quantifier 36 | import Type.Class.Higher 37 | import Type.Class.Known 38 | import Type.Class.Witness 39 | import Type.Family.Either 40 | 41 | -- (:|:) {{{ 42 | 43 | data ((f :: k -> *) :|: (g :: k -> *)) :: k -> * where 44 | L :: !(f a) -> (f :|: g) a 45 | R :: !(g a) -> (f :|: g) a 46 | infixr 4 :|: 47 | 48 | deriving instance (Eq (f a), Eq (g a)) => Eq ((f :|: g) a) 49 | deriving instance (Ord (f a), Ord (g a)) => Ord ((f :|: g) a) 50 | deriving instance (Show (f a), Show (g a)) => Show ((f :|: g) a) 51 | deriving instance (Read (f a), Read (g a)) => Read ((f :|: g) a) 52 | 53 | instance (Eq1 f, Eq1 g) => Eq1 (f :|: g) where 54 | eq1 = \case 55 | L a -> \case 56 | L b -> a =#= b 57 | _ -> False 58 | R a -> \case 59 | R b -> a =#= b 60 | _ -> False 61 | 62 | instance (Ord1 f, Ord1 g) => Ord1 (f :|: g) where 63 | compare1 = \case 64 | L a -> \case 65 | L b -> compare1 a b 66 | R _ -> LT 67 | R a -> \case 68 | L _ -> GT 69 | R b -> compare1 a b 70 | 71 | instance (Show1 f, Show1 g) => Show1 (f :|: g) where 72 | showsPrec1 d = showParen (d > 10) . \case 73 | L a -> showString "L " 74 | . showsPrec1 11 a 75 | R b -> showString "R " 76 | . showsPrec1 11 b 77 | 78 | instance (Read1 f, Read1 g) => Read1 (f :|: g) where 79 | readsPrec1 d = readParen (d > 10) $ \s0 -> 80 | [ (a >>- Some . L,s2) 81 | | ("L",s1) <- lex s0 82 | , (a,s2) <- readsPrec1 11 s1 83 | ] ++ 84 | [ (a >>- Some . R,s2) 85 | | ("R",s1) <- lex s0 86 | , (a,s2) <- readsPrec1 11 s1 87 | ] 88 | 89 | (>|<) :: (f a -> r) -> (g a -> r) -> (f :|: g) a -> r 90 | f >|< g = \case 91 | L a -> f a 92 | R b -> g b 93 | infixr 2 >|< 94 | 95 | instance Functor1 ((:|:) f) where 96 | map1 f = \case 97 | L a -> L a 98 | R b -> R $ f b 99 | 100 | instance Foldable1 ((:|:) f) where 101 | foldMap1 f = \case 102 | L _ -> mempty 103 | R b -> f b 104 | 105 | instance Traversable1 ((:|:) f) where 106 | traverse1 f = \case 107 | L a -> pure $ L a 108 | R b -> R <$> f b 109 | 110 | instance Bifunctor1 (:|:) where 111 | bimap1 f g = \case 112 | L a -> L $ f a 113 | R b -> R $ g b 114 | 115 | instance (Witness p q (f a), Witness p q (g a)) => Witness p q ((f :|: g) a) where 116 | type WitnessC p q ((f :|: g) a) = (Witness p q (f a), Witness p q (g a)) 117 | (\\) r = \case 118 | L a -> r \\ a 119 | R b -> r \\ b 120 | 121 | -- }}} 122 | 123 | -- (:+:) {{{ 124 | 125 | data ((f :: k -> *) :+: (g :: l -> *)) :: Either k l -> * where 126 | L' :: !(f a) -> (f :+: g) (Left a) 127 | R' :: !(g b) -> (f :+: g) (Right b) 128 | infixr 4 :+: 129 | 130 | deriving instance (Eq (f (FromLeft e)), Eq (g (FromRight e))) => Eq ((f :+: g) e) 131 | deriving instance (Ord (f (FromLeft e)), Ord (g (FromRight e))) => Ord ((f :+: g) e) 132 | deriving instance (Show (f (FromLeft e)), Show (g (FromRight e))) => Show ((f :+: g) e) 133 | 134 | instance (Eq1 f, Eq1 g) => Eq1 (f :+: g) where 135 | eq1 = \case 136 | L' a -> \case 137 | L' b -> a =#= b 138 | R' a -> \case 139 | R' b -> a =#= b 140 | 141 | instance (Ord1 f, Ord1 g) => Ord1 (f :+: g) where 142 | compare1 = \case 143 | L' a -> \case 144 | L' b -> compare1 a b 145 | R' a -> \case 146 | R' b -> compare1 a b 147 | 148 | instance (Show1 f, Show1 g) => Show1 (f :+: g) where 149 | showsPrec1 d = showParen (d > 10) . \case 150 | L' a -> showString "L' " 151 | . showsPrec1 11 a 152 | R' b -> showString "R' " 153 | . showsPrec1 11 b 154 | 155 | instance (Read1 f, Read1 g) => Read1 (f :+: g) where 156 | readsPrec1 d = readParen (d > 10) $ \s0 -> 157 | [ (a >>- Some . L',s2) 158 | | ("L'",s1) <- lex s0 159 | , (a,s2) <- readsPrec1 11 s1 160 | ] ++ 161 | [ (a >>- Some . R',s2) 162 | | ("R'",s1) <- lex s0 163 | , (a,s2) <- readsPrec1 11 s1 164 | ] 165 | 166 | {- 167 | instance (DecEquality f, DecEquality g) => DecEquality (f :+: g) where 168 | decideEquality = \case 169 | L' a -> \case 170 | L' b -> decCase (decideEquality a b) (\Refl -> Proven Refl) (\contra -> Refuted $ contra . toEquality fromLeftCong) 171 | R' _ -> Refuted $ 172 | R' a -> \case 173 | L' b -> Refuted undefined 174 | R' b -> undefined 175 | -} 176 | 177 | 178 | (>+<) :: (forall a. (e ~ Left a) => f a -> r) -> (forall b. (e ~ Right b) => g b -> r) -> (f :+: g) e -> r 179 | f >+< g = \case 180 | L' a -> f a 181 | R' b -> g b 182 | infixr 2 >+< 183 | 184 | instance Known f a => Known (f :+: g) (Left a) where 185 | type KnownC (f :+: g) (Left a) = Known f a 186 | known = L' known 187 | 188 | instance Known g b => Known (f :+: g) (Right b) where 189 | type KnownC (f :+: g) (Right b) = Known g b 190 | known = R' known 191 | 192 | instance Functor1 ((:+:) f) where 193 | map1 f = \case 194 | L' a -> L' a 195 | R' b -> R' $ f b 196 | 197 | instance Foldable1 ((:+:) f) where 198 | foldMap1 f = \case 199 | L' _ -> mempty 200 | R' b -> f b 201 | 202 | instance Traversable1 ((:+:) f) where 203 | traverse1 f = \case 204 | L' a -> pure $ L' a 205 | R' b -> R' <$> f b 206 | 207 | instance Bifunctor1 (:+:) where 208 | bimap1 f g = \case 209 | L' a -> L' $ f a 210 | R' b -> R' $ g b 211 | 212 | instance Witness p q (f a) => Witness p q ((f :+: g) (Left a)) where 213 | type WitnessC p q ((f :+: g) (Left a)) = Witness p q (f a) 214 | r \\ L' a = r \\ a 215 | 216 | instance Witness p q (g b) => Witness p q ((f :+: g) (Right b)) where 217 | type WitnessC p q ((f :+: g) (Right b)) = Witness p q (g b) 218 | r \\ R' b = r \\ b 219 | 220 | -- }}} 221 | 222 | -------------------------------------------------------------------------------- /src/Data/Type/Conjunction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE GADTs #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Type.Conjunction 18 | -- Copyright : Copyright (C) 2015 Kyle Carter 19 | -- License : BSD3 20 | -- 21 | -- Maintainer : Kyle Carter 22 | -- Stability : experimental 23 | -- Portability : RankNTypes 24 | -- 25 | -- Two type combinators for working with conjunctions: 26 | -- A /fanout/ combinator '(:&:)', and a /par/ combinator '(:*:)'. 27 | -- 28 | -- These are analogous to '(&&&)' and '(***)' from 'Control.Arrow', 29 | -- respectively. 30 | -- 31 | ----------------------------------------------------------------------------- 32 | 33 | module Data.Type.Conjunction where 34 | 35 | import Data.Type.Index.Trans 36 | import Type.Class.Higher 37 | import Type.Class.Known 38 | import Type.Class.Witness 39 | import Type.Family.Tuple 40 | 41 | -- (:&:) {{{ 42 | 43 | data ((f :: k -> *) :&: (g :: k -> *)) :: k -> * where 44 | (:&:) :: !(f a) -> !(g a) -> (f :&: g) a 45 | infixr 6 :&: 46 | 47 | deriving instance (Eq (f a), Eq (g a)) => Eq ((f :&: g) a) 48 | deriving instance (Ord (f a), Ord (g a)) => Ord ((f :&: g) a) 49 | deriving instance (Show (f a), Show (g a)) => Show ((f :&: g) a) 50 | deriving instance (Read (f a), Read (g a)) => Read ((f :&: g) a) 51 | 52 | instance (Eq1 f, Eq1 g) => Eq1 (f :&: g) where 53 | eq1 (a :&: b) (c :&: d) = a =#= c && b =#= d 54 | 55 | instance (Ord1 f, Ord1 g) => Ord1 (f :&: g) where 56 | compare1 (a :&: b) (c :&: d) = compare1 a c `mappend` compare1 b d 57 | 58 | instance (Show1 f, Show1 g) => Show1 (f :&: g) where 59 | showsPrec1 d (a :&: b) = showParen (d > 5) 60 | $ showsPrec1 11 a 61 | . showString " :&: " 62 | . showsPrec1 11 b 63 | 64 | fanFst :: (f :&: g) a -> f a 65 | fanFst (a :&: _) = a 66 | 67 | fanSnd :: (f :&: g) a -> g a 68 | fanSnd (_ :&: b) = b 69 | 70 | (.&.) :: (f a -> h b) -> (g a -> i b) -> (f :&: g) a -> (h :&: i) b 71 | (f .&. g) (a :&: b) = f a :&: g b 72 | infixr 3 .&. 73 | 74 | fanFirst :: (f a -> g a) -> (f :&: h) a -> (g :&: h) a 75 | fanFirst f (a :&: b) = f a :&: b 76 | 77 | uncurryFan :: (f a -> g a -> r) -> (f :&: g) a -> r 78 | uncurryFan f (a :&: b) = f a b 79 | 80 | curryFan :: ((f :&: g) a -> r) -> f a -> g a -> r 81 | curryFan f a b = f (a :&: b) 82 | 83 | instance (Known f a, Known g a) => Known (f :&: g) a where 84 | known = known :&: known 85 | 86 | instance Functor1 ((:&:) f) where 87 | map1 f (a :&: b) = a :&: f b 88 | 89 | instance Foldable1 ((:&:) f) where 90 | foldMap1 f (_ :&: b) = f b 91 | 92 | instance Traversable1 ((:&:) f) where 93 | traverse1 f (a :&: b) = (:&:) a <$> f b 94 | 95 | instance Bifunctor1 (:&:) where 96 | bimap1 f g (a :&: b) = f a :&: g b 97 | 98 | instance (Witness p q (f a), Witness s t (g a)) => Witness (p,s) (q,t) ((f :&: g) a) where 99 | type WitnessC (p,s) (q,t) ((f :&: g) a) = (Witness p q (f a), Witness s t (g a)) 100 | r \\ a :&: b = r \\ a \\ b 101 | 102 | -- }}} 103 | 104 | -- (:*:) {{{ 105 | 106 | data ((f :: k -> *) :*: (g :: l -> *)) :: (k,l) -> * where 107 | (:*:) :: !(f a) -> !(g b) -> (f :*: g) (a#b) 108 | infixr 6 :*: 109 | 110 | deriving instance (Eq (f (Fst p)), Eq (g (Snd p))) => Eq ((f :*: g) p) 111 | deriving instance (Ord (f (Fst p)), Ord (g (Snd p))) => Ord ((f :*: g) p) 112 | deriving instance (Show (f (Fst p)), Show (g (Snd p))) => Show ((f :*: g) p) 113 | deriving instance (p ~ (a#b), Read (f a), Read (g b)) => Read ((f :*: g) p) 114 | 115 | instance (Eq1 f, Eq1 g) => Eq1 (f :*: g) where 116 | eq1 (a :*: b) (c :*: d) = a =#= c && b =#= d 117 | 118 | instance (Ord1 f, Ord1 g) => Ord1 (f :*: g) where 119 | compare1 (a :*: b) (c :*: d) = compare1 a c `mappend` compare1 b d 120 | 121 | instance (Show1 f, Show1 g) => Show1 (f :*: g) where 122 | showsPrec1 d (a :*: b) = showParen (d > 5) 123 | $ showsPrec1 11 a 124 | . showString " :*: " 125 | . showsPrec1 11 b 126 | 127 | parFst :: (f :*: g) p -> f (Fst p) 128 | parFst (a :*: _) = a 129 | 130 | parSnd :: (f :*: g) p -> g (Snd p) 131 | parSnd (_ :*: b) = b 132 | 133 | uncurryPar :: (forall a b. (p ~ (a#b)) => f a -> g b -> r) -> (f :*: g) p -> r 134 | uncurryPar f (a :*: b) = f a b 135 | 136 | curryPar :: ((f :*: g) (a#b) -> r) -> f a -> g b -> r 137 | curryPar f a b = f (a :*: b) 138 | 139 | instance (p ~ (a#b), Known f a, Known g b) => Known (f :*: g) p where 140 | known = known :*: known 141 | 142 | instance Functor1 ((:*:) f) where 143 | map1 f (a :*: b) = a :*: f b 144 | 145 | instance Foldable1 ((:*:) f) where 146 | foldMap1 f (_ :*: b) = f b 147 | 148 | instance Traversable1 ((:*:) f) where 149 | traverse1 f (a :*: b) = (:*:) a <$> f b 150 | 151 | instance Bifunctor1 (:*:) where 152 | bimap1 f g (a :*: b) = f a :*: g b 153 | 154 | instance IxFunctor1 (IxSecond (:~:)) ((:*:) f) where 155 | imap1 f (a :*: b) = a :*: f (IxSecond Refl) b 156 | 157 | -- f :: (k -> *) ==> ((:*:) f) :: (l -> *) -> (k,l) -> * 158 | 159 | _fst :: (a#b) :~: (c#d) -> a :~: c 160 | _fst Refl = Refl 161 | 162 | _snd :: (a#b) :~: (c#d) -> b :~: d 163 | _snd Refl = Refl 164 | 165 | {- 166 | instance (BoolEquality f, BoolEquality g) => BoolEquality (f :*: g) where 167 | (a :*: b) .== (c :*: d) = a .== c .&& b .== d 168 | -} 169 | 170 | instance (DecEquality f, DecEquality g) => DecEquality (f :*: g) where 171 | decideEquality (a :*: b) (c :*: d) = case decideEquality a c of 172 | Proven p -> case decideEquality b d of 173 | Proven q -> Proven $ Refl \\ p \\ q 174 | Refuted q -> Refuted $ q . _snd 175 | Refuted p -> Refuted $ p . _fst 176 | 177 | instance (Witness p q (f a), Witness s t (g b), x ~ (a#b)) => Witness (p,s) (q,t) ((f :*: g) x) where 178 | type WitnessC (p,s) (q,t) ((f :*: g) x) = (Witness p q (f (Fst x)), Witness s t (g (Snd x))) 179 | r \\ a :*: b = r \\ a \\ b 180 | 181 | -- }}} 182 | 183 | -- (:&&:) {{{ 184 | 185 | data (f :: k -> *) :&&: (g :: k -> *) where 186 | (:&&:) :: !(f a) -> !(g a) -> f :&&: g 187 | infixr 6 :&&: 188 | 189 | instance (TestEquality f, TestEquality g, Eq1 f, Eq1 g) => Eq (f :&&: g) where 190 | p == q = case exConjEq p q of 191 | Just (a :&&: b, c :&&: d) -> eq1 a b && eq1 c d 192 | _ -> False 193 | 194 | -- Defaulting to LT when terms are incomparable is dubious 195 | instance (TestEquality f, TestEquality g, Ord1 f, Ord1 g) => Ord (f :&&: g) where 196 | compare p q = case exConjEq p q of 197 | Just (a :&&: b, c :&&: d) -> compare1 a b `mappend` compare1 c d 198 | _ -> LT 199 | 200 | instance (Show1 f, Show1 g) => Show (f :&&: g) where 201 | showsPrec d (a :&&: b) = showParen (d > 6) 202 | $ showsPrec1 7 a 203 | . showString " :&&: " 204 | . showsPrec1 6 b 205 | 206 | exConjEq :: (TestEquality f, TestEquality g) => f :&&: g -> f :&&: g -> Maybe (f :&&: f, g :&&: g) 207 | exConjEq (a :&&: c) (b :&&: d) = a =?= b //? c =?= d //? return (a :&&: b,c :&&: d) 208 | 209 | -- }}} 210 | 211 | -------------------------------------------------------------------------------- /src/Type/Class/Witness.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableSuperClasses #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE AllowAmbiguousTypes #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE PatternSynonyms #-} 7 | {-# LANGUAGE ConstraintKinds #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE FunctionalDependencies #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE LambdaCase #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE KindSignatures #-} 16 | {-# LANGUAGE DataKinds #-} 17 | {-# LANGUAGE PolyKinds #-} 18 | {-# LANGUAGE GADTs #-} 19 | ----------------------------------------------------------------------------- 20 | -- | 21 | -- Module : Type.Class.Witness 22 | -- Copyright : Copyright (C) 2015 Kyle Carter 23 | -- License : BSD3 24 | -- 25 | -- Maintainer : Kyle Carter 26 | -- Stability : experimental 27 | -- Portability : RankNTypes 28 | -- 29 | -- A type @t@ that is a @'Witness' p q t@ provides a 'Constraint' entailment 30 | -- of @q@, given that @p@ holds. 31 | -- 32 | -- The 'Witness' class uses an associated 'Constraint' @WitnessC@ to 33 | -- maintain backwards inference of 'Witness' instances with respect 34 | -- to type refinement. See the 'Known' class for more information. 35 | -- 36 | -- Heavily inspired by ekmett's constraints library: 37 | -- 38 | -- 39 | -- The code provided here does not /quite/ subsume the @constraints@ 40 | -- library, as we do not give classes and instances for representing 41 | -- the standard library's class heirarchy and instance definitions. 42 | ---------------------------------------------------------------------------- 43 | 44 | module Type.Class.Witness 45 | ( module Type.Class.Witness 46 | , module Exports 47 | ) where 48 | 49 | import Type.Class.Known 50 | import Type.Family.Constraint 51 | 52 | import Data.Type.Equality as Exports 53 | import Data.Void as Exports hiding (absurd) 54 | import qualified Data.Void as Void 55 | 56 | import Prelude hiding (id,(.)) 57 | import Control.Category 58 | import Control.Arrow 59 | import Unsafe.Coerce 60 | 61 | -- Wit {{{ 62 | 63 | -- | A reified 'Constraint'. 64 | data Wit :: Constraint -> * where 65 | Wit :: c => Wit c 66 | 67 | data Wit1 :: (k -> Constraint) -> k -> * where 68 | Wit1 :: c a => Wit1 c a 69 | 70 | -- }}} 71 | 72 | -- (:-) {{{ 73 | 74 | -- | Reified evidence of 'Constraint' entailment. 75 | -- 76 | -- Given a term of @p :- q@, the Constraint @q@ holds 77 | -- if @p@ holds. 78 | -- 79 | -- Entailment of 'Constraint's form a 'Category': 80 | -- 81 | -- >>> id :: p :- p 82 | -- >>> (.) :: (q :- r) -> (p :-> q) -> (p :- r) 83 | data (:-) :: Constraint -> Constraint -> * where 84 | Sub :: { getSub :: p => Wit q } -> p :- q 85 | infixr 4 :- 86 | 87 | instance Category (:-) where 88 | id = Sub Wit 89 | Sub bc . Sub ab = Sub $ bc \\ ab 90 | 91 | transC :: (b :- c) -> (a :- b) -> a :- c 92 | transC = (.) 93 | 94 | -- }}} 95 | 96 | -- Witness {{{ 97 | 98 | -- | A general eliminator for entailment. 99 | -- 100 | -- Given a term of type @t@ with an instance @Witness p q t@ 101 | -- and a term of type @r@ that depends on 'Constraint' @q@, 102 | -- we can reduce the Constraint to @p@. 103 | -- 104 | -- If @p@ is @ØC@, i.e. the empty 'Constraint' @()@, then 105 | -- a Witness @t@ can completely discharge the Constraint @q@. 106 | class WitnessC p q t => Witness (p :: Constraint) (q :: Constraint) (t :: *) | t -> p q where 107 | type WitnessC p q t :: Constraint 108 | type WitnessC p q t = ØC 109 | (\\) :: p => (q => r) -> t -> r 110 | infixl 1 \\ 111 | 112 | (//) :: (Witness p q t, p) => t -> (q => r) -> r 113 | t // r = r \\ t 114 | infixr 0 // 115 | 116 | -- | Convert a 'Witness' to a canonical reified 'Constraint'. 117 | witnessed :: Witness ØC q t => t -> Wit q 118 | witnessed t = Wit \\ t 119 | 120 | -- | Convert a 'Witness' to a canonical reified entailment. 121 | entailed :: Witness p q t => t -> p :- q 122 | entailed t = Sub (Wit \\ t) 123 | 124 | -- }}} 125 | 126 | -- Constraint Combinators {{{ 127 | 128 | class Fails (c :: Constraint) where 129 | failC :: c :- Fail 130 | 131 | absurdC :: Fails a => a :- b 132 | absurdC = contraC failC 133 | 134 | class c => Const (c :: Constraint) (d :: k) where 135 | constC :: Wit c 136 | 137 | instance c => Const c d where 138 | constC = Wit 139 | 140 | class f (g a) => (∘) (f :: l -> Constraint) (g :: k -> l) (a :: k) where 141 | compC :: Wit (f (g a)) 142 | 143 | instance f (g a) => (f ∘ g) a where 144 | compC = Wit 145 | infixr 9 ∘ 146 | 147 | class (f a,g a) => (∧) (f :: k -> Constraint) (g :: k -> Constraint) (a :: k) where 148 | conjC :: (Wit (f a),Wit (g a)) 149 | infixr 7 ∧ 150 | 151 | instance (f a,g a) => (f ∧ g) a where 152 | conjC = (Wit,Wit) 153 | 154 | class (∨) (f :: k -> Constraint) (g :: k -> Constraint) (a :: k) where 155 | disjC :: Either (Wit (f a)) (Wit (g a)) 156 | infixr 6 ∨ 157 | 158 | eitherC :: forall f g a b. f a :- b -> g a :- b -> (f ∨ g) a :- b 159 | eitherC f g = Sub $ case (disjC :: Either (Wit (f a)) (Wit (g a)),f,g) of 160 | (Left a,Sub b,_ ) -> b \\ a 161 | (Right a,_ ,Sub b) -> b \\ a 162 | 163 | pureC :: b => a :- b 164 | pureC = Sub Wit 165 | 166 | contraC :: a :- Fail -> a :- b 167 | contraC = (bottom .) 168 | 169 | -- }}} 170 | 171 | -- Forall {{{ 172 | 173 | class Forall (p :: k -> Constraint) (q :: k -> Constraint) where 174 | forall :: p a :- q a 175 | default forall :: q a => p a :- q a 176 | forall = pureC 177 | 178 | -- }}} 179 | 180 | -- Initial/Terminal {{{ 181 | 182 | toEquality :: (a ~ b) :- (c ~ d) -> a :~: b -> c :~: d 183 | toEquality p Refl = Refl \\ p 184 | 185 | commute :: (a ~ b) :- (b ~ a) 186 | commute = Sub Wit 187 | 188 | type family Holds (b :: Bool) (c :: Constraint) :: Constraint where 189 | Holds True c = c 190 | Holds False c = ØC 191 | 192 | falso :: (b ~ False) :- Holds b c 193 | falso = Sub Wit 194 | 195 | top :: a :- ØC 196 | top = Sub Wit 197 | 198 | bottom :: Fail :- c 199 | bottom = falso 200 | 201 | 202 | 203 | instance Witness ØC c (Wit c) where 204 | r \\ Wit = r 205 | 206 | instance Witness ØC (c a) (Wit1 c a) where 207 | r \\ Wit1 = r 208 | 209 | -- | An entailment @p :- q@ is a Witness of @q@, given @p@. 210 | instance Witness p q (p :- q) where 211 | r \\ Sub Wit = r 212 | 213 | -- | A type equality @a ':~:' b@ is a Witness that @(a ~ b)@. 214 | instance Witness ØC (a ~ b) (a :~: b) where 215 | r \\ Refl = r 216 | 217 | -- | If the constraint @c@ holds, there is a canonical construction 218 | -- for a term of type @'Wit' c@, viz. the constructor @Wit@. 219 | instance c => Known Wit c where 220 | type KnownC Wit c = c 221 | known = Wit 222 | 223 | instance c a => Known (Wit1 c) a where 224 | type KnownC (Wit1 c) a = c a 225 | known = Wit1 226 | 227 | -- | Constraint chaining under @Maybe@. 228 | (//?) :: (Witness p q t, p) => Maybe t -> (q => Maybe r) -> Maybe r 229 | (//?) = \case 230 | Just t -> (\\ t) 231 | _ -> \_ -> Nothing 232 | infixr 0 //? 233 | 234 | (//?+) :: (Witness p q t, p) => Either e t -> (q => Either e r) -> Either e r 235 | (//?+) = \case 236 | Left e -> \_ -> Left e 237 | Right t -> (\\ t) 238 | infixr 0 //?+ 239 | 240 | witMaybe :: (Witness p q t, p) => Maybe t -> (q => Maybe r) -> Maybe r -> Maybe r 241 | witMaybe mt y n = case mt of 242 | Just t -> y \\ t 243 | _ -> n 244 | 245 | qed :: Maybe (a :~: a) 246 | qed = Just Refl 247 | 248 | impossible :: a -> Void 249 | impossible = unsafeCoerce 250 | 251 | exFalso :: Wit Fail -> a 252 | exFalso p = castWith q () 253 | where 254 | q :: () :~: a 255 | q = toEquality (contraC r) Refl 256 | r :: (b ~ b) :- Fail 257 | r = Sub p 258 | 259 | (=?=) :: TestEquality f => f a -> f b -> Maybe (a :~: b) 260 | (=?=) = testEquality 261 | infix 4 =?= 262 | 263 | class TestEquality1 (f :: k -> l -> *) where 264 | testEquality1 :: f a c -> f b c -> Maybe (a :~: b) 265 | 266 | (=??=) :: TestEquality1 f => f a c -> f b c -> Maybe (a :~: b) 267 | (=??=) = testEquality1 268 | infix 4 =??= 269 | 270 | -- }}} 271 | 272 | -- Dec {{{ 273 | 274 | data Dec a 275 | = Proven a 276 | | Refuted (a -> Void) 277 | 278 | class DecEquality (f :: k -> *) where 279 | decideEquality :: f a -> f b -> Dec (a :~: b) 280 | 281 | decCase :: Dec a 282 | -> (a -> r) 283 | -> ((a -> Void) -> r) 284 | -> r 285 | decCase d y n = case d of 286 | Proven a -> y a 287 | Refuted b -> n b 288 | 289 | -- }}} 290 | 291 | absurd :: Arrow p => p Void a 292 | absurd = arr Void.absurd 293 | 294 | {- 295 | -- Category Classes {{{ 296 | 297 | class Category c => Monoidal (c :: k -> k -> *) where 298 | type Tensor c :: k -> k -> k 299 | type Unit c :: k 300 | (.*.) :: c v w -> c x y -> c (Tensor c v x) (Tensor c w y) 301 | assoc :: c (Tensor c (Tensor c x y) z) (Tensor c x (Tensor c y z)) 302 | unitL :: c (Tensor c (Unit c) x) x 303 | unitR :: c (Tensor c x (Unit c)) x 304 | infixr 3 .*. 305 | 306 | class Category c => Symmetric (c :: k -> k -> *) where 307 | symm :: c a b -> c b a 308 | 309 | instance Category p => Symmetric (Bij p) where 310 | symm p = bwd p <-> fwd p 311 | 312 | instance Monoidal (->) where 313 | type Tensor (->) = (,) 314 | type Unit (->) = () 315 | (f .*. g) (a,b) = (f a,g b) 316 | assoc ((x,y),z) = (x,(y,z)) 317 | unitL (_,x) = x 318 | unitR (x,_) = x 319 | 320 | instance (Symmetric p, Monoidal p) => Monoidal (Bij p) where 321 | type Tensor (Bij p) = Tensor p 322 | type Unit (Bij p) = Unit p 323 | (.*.) = (***) 324 | assoc = assoc <-> symm assoc 325 | unitL = unitL <-> symm unitL 326 | unitR = unitR <-> symm unitR 327 | 328 | (***) :: Monoidal p => Bij p a b -> Bij p c d -> Bij p (Tensor p a c) (Tensor p b d) 329 | f *** g = (fwd f .*. fwd g) <-> (bwd f .*. bwd g) 330 | infixr 3 *** 331 | 332 | -- }}} 333 | -} 334 | 335 | -------------------------------------------------------------------------------- /src/Data/Type/Product.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE ConstraintKinds #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE LambdaCase #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# LANGUAGE KindSignatures #-} 14 | {-# LANGUAGE DataKinds #-} 15 | {-# LANGUAGE PolyKinds #-} 16 | {-# LANGUAGE GADTs #-} 17 | ----------------------------------------------------------------------------- 18 | -- | 19 | -- Module : Data.Type.Product 20 | -- Copyright : Copyright (C) 2015 Kyle Carter 21 | -- License : BSD3 22 | -- 23 | -- Maintainer : Kyle Carter 24 | -- Stability : experimental 25 | -- Portability : RankNTypes 26 | -- 27 | -- Type combinators for type-level lists, 28 | -- lifting @(f :: k -> *)@ to @(Prod f :: [k] -> *)@, 29 | -- as well as its constructions, manipulations, and 30 | -- eliminations. 31 | -- 32 | -- 'Prod' is similar in nature to a few others in the Haskell ecosystem, such as: 33 | -- 34 | -- Oleg Kiselyov's 'HList', from , and 35 | -- 36 | -- Kenneth Foner's 'ConicList', from . 37 | -- 38 | ----------------------------------------------------------------------------- 39 | 40 | module Data.Type.Product where 41 | 42 | import Data.Type.Boolean 43 | import Data.Type.Combinator 44 | import Data.Type.Conjunction 45 | import Data.Type.Index 46 | import Data.Type.Length 47 | -- import Data.Type.Quantifier 48 | import Type.Class.Higher 49 | import Type.Class.Known 50 | import Type.Class.Witness 51 | import Type.Family.Constraint 52 | import Type.Family.List 53 | 54 | data Prod (f :: k -> *) :: [k] -> * where 55 | Ø :: Prod f Ø 56 | (:<) :: !(f a) -> !(Prod f as) -> Prod f (a :< as) 57 | infixr 5 :< 58 | 59 | deriving instance ListC (Eq <$> f <$> as) => Eq (Prod f as) 60 | deriving instance 61 | ( ListC (Eq <$> f <$> as) 62 | , ListC (Ord <$> f <$> as) 63 | ) => Ord (Prod f as) 64 | deriving instance ListC (Show <$> f <$> as) => Show (Prod f as) 65 | 66 | instance Eq1 f => Eq1 (Prod f) where 67 | eq1 = \case 68 |  Ø -> \case 69 | Ø -> True 70 | a :< as -> \case 71 | b :< bs -> a =#= b && as =#= bs 72 | 73 | instance Ord1 f => Ord1 (Prod f) where 74 | compare1 = \case 75 | Ø -> \case 76 | Ø -> EQ 77 | a :< as -> \case 78 | b :< bs -> compare1 a b `mappend` compare1 as bs 79 | 80 | instance Show1 f => Show1 (Prod f) where 81 | showsPrec1 d = \case 82 | Ø -> showString "Ø" 83 | a :< as -> showParen (d > 5) 84 | $ showsPrec1 6 a 85 | . showString " :< " 86 | . showsPrec1 6 as 87 | 88 | instance Read1 f => Read1 (Prod f) where 89 | readsPrec1 d s0 = 90 | [ (Some Ø,s1) 91 | | ("Ø",s1) <- lex s0 92 | ] ++ readParen (d > 5) ( \s1 -> 93 | [ (x >>- \a -> xs >>- \as -> Some $ a :< as,s4) 94 | | (x,s2) <- readsPrec1 6 s1 95 | , (":<",s3) <- lex s2 96 | , (xs,s4) <- readsPrec1 5 s3 97 | ] 98 | ) s0 99 | 100 | instance BoolEquality f => BoolEquality (Prod f) where 101 | boolEquality = \case 102 | Ø -> \case 103 | Ø -> True_ 104 | (:<){} -> False_ 105 | a :< as -> \case 106 | b :< bs -> case a .== b of 107 | True_ -> case as .== bs of 108 | True_ -> True_ 109 | False_ -> False_ 110 | False_ -> False_ 111 | Ø -> False_ 112 | 113 | instance TestEquality f => TestEquality (Prod f) where 114 | testEquality = \case 115 | Ø -> \case 116 | Ø -> qed 117 | _ -> Nothing 118 | a :< as -> \case 119 | b :< bs -> a =?= b //? as =?= bs //? qed 120 | _ -> Nothing 121 | 122 | -- | Construct a two element Prod. 123 | -- Since the precedence of (:>) is higher than (:<), 124 | -- we can conveniently write lists like: 125 | -- 126 | -- >>> a :< b :> c 127 | -- 128 | -- Which is identical to: 129 | -- 130 | -- >>> a :< b :< c :< Ø 131 | -- 132 | pattern (:>) :: (f :: k -> *) (a :: k) -> f (b :: k) -> Prod f '[a,b] 133 | pattern a :> b = a :< b :< Ø 134 | infix 6 :> 135 | 136 | -- | Build a singleton Prod. 137 | only :: f a -> Prod f '[a] 138 | only = (:< Ø) 139 | 140 | -- | snoc function. insert an element at the end of the list. 141 | (>:) :: Prod f as -> f a -> Prod f (as >: a) 142 | (>:) = \case 143 | Ø -> only 144 | b :< as -> (b :<) . (as >:) 145 | infixl 6 >: 146 | 147 | head' :: Prod f (a :< as) -> f a 148 | head' (a :< _) = a 149 | 150 | tail' :: Prod f (a :< as) -> Prod f as 151 | tail' (_ :< as) = as 152 | 153 | -- | Get all but the last element of a non-empty Prod. 154 | init' :: Prod f (a :< as) -> Prod f (Init' a as) 155 | init' (a :< as) = case as of 156 | Ø -> Ø 157 | (:<){} -> a :< init' as 158 | 159 | -- | Get the last element of a non-empty Prod. 160 | last' :: Prod f (a :< as) -> f (Last' a as) 161 | last' (a :< as) = case as of 162 | Ø -> a 163 | (:<){} -> last' as 164 | 165 | reverse' :: Prod f as -> Prod f (Reverse as) 166 | reverse' = \case 167 | Ø -> Ø 168 | a :< as -> reverse' as >: a 169 | 170 | append' :: Prod f as -> Prod f bs -> Prod f (as ++ bs) 171 | append' = \case 172 | Ø -> id 173 | a :< as -> (a :<) . append' as 174 | 175 | {- 176 | lookup' :: TestEquality f => f a -> Prod (f :&: g) as -> Maybe (g a) 177 | lookup' a = \case 178 | Ø -> Nothing 179 | (b :&: v) :< bs -> witMaybe (a =?= b) (Just v) $ lookup' a bs 180 | -} 181 | 182 | lookupPar :: TestEquality f => f a -> Prod (f :*: g) as -> Maybe (Some g) 183 | lookupPar a = \case 184 | Ø -> Nothing 185 | (b :*: v) :< bs -> witMaybe (a =?= b) (Just $ Some v) $ lookupPar a bs 186 | 187 | permute :: Known Length bs => (forall x. Index bs x -> Index as x) -> Prod f as -> Prod f bs 188 | permute f as = permute' f as known 189 | 190 | permute' :: (forall x. Index bs x -> Index as x) -> Prod f as -> Length bs -> Prod f bs 191 | permute' f as = \case 192 | LZ -> Ø 193 | LS l -> index (f IZ) as :< permute' (f . IS) as l 194 | 195 | -- Tuple {{{ 196 | 197 | -- | A Prod of simple Haskell types. 198 | type Tuple = Prod I 199 | 200 | -- | Singleton Tuple. 201 | only_ :: a -> Tuple '[a] 202 | only_ = only . I 203 | 204 | -- | Cons onto a Tuple. 205 | pattern (::<) :: a -> Tuple as -> Tuple (a :< as) 206 | pattern a ::< as = I a :< as 207 | infixr 5 ::< 208 | 209 | -- | Snoc onto a Tuple. 210 | (>::) :: Tuple as -> a -> Tuple (as >: a) 211 | (>::) = \case 212 | Ø -> only_ 213 | b :< as -> (b :<) . (as >::) 214 | infixl 6 >:: 215 | 216 | -- }}} 217 | 218 | elimProd :: p Ø -> (forall x xs. Index as x -> f x -> p xs -> p (x :< xs)) -> Prod f as -> p as 219 | elimProd n c = \case 220 | Ø -> n 221 | a :< as -> c IZ a $ elimProd n (c . IS) as 222 | 223 | onHead' :: (f a -> f b) -> Prod f (a :< as) -> Prod f (b :< as) 224 | onHead' f (a :< as) = f a :< as 225 | 226 | onTail' :: (Prod f as -> Prod f bs) -> Prod f (a :< as) -> Prod f (a :< bs) 227 | onTail' f (a :< as) = a :< f as 228 | 229 | uncurry' :: (f a -> Prod f as -> r) -> Prod f (a :< as) -> r 230 | uncurry' f (a :< as) = f a as 231 | 232 | curry' :: (l ~ (a :< as)) => (Prod f l -> r) -> f a -> Prod f as -> r 233 | curry' f a as = f $ a :< as 234 | 235 | index :: Index as a -> Prod f as -> f a 236 | index = \case 237 | IZ -> head' 238 | IS x -> index x . tail' 239 | 240 | select :: Prod (Index as) bs -> Prod f as -> Prod f bs 241 | select = \case 242 | Ø -> pure Ø 243 | x: (:<) <$> index x <*> select xs 244 | 245 | indices :: forall as. Known Length as => Prod (Index as) as 246 | indices = indices' known 247 | 248 | indices' :: Length as -> Prod (Index as) as 249 | indices' = \case 250 | LZ -> Ø 251 | LS l -> IZ :< map1 IS (indices' l) 252 | 253 | 254 | instance Functor1 Prod where 255 | map1 f = \case 256 | Ø -> Ø 257 | a :< as -> f a :< map1 f as 258 | 259 | instance IxFunctor1 Index Prod where 260 | imap1 f = \case 261 | Ø -> Ø 262 | a :< as -> f IZ a :< imap1 (f . IS) as 263 | 264 | instance Foldable1 Prod where 265 | foldMap1 f = \case 266 | Ø -> mempty 267 | a :< as -> f a `mappend` foldMap1 f as 268 | 269 | instance IxFoldable1 Index Prod where 270 | ifoldMap1 f = \case 271 | Ø -> mempty 272 | a :< as -> f IZ a `mappend` ifoldMap1 (f . IS) as 273 | 274 | instance Traversable1 Prod where 275 | traverse1 f = \case 276 | Ø -> pure Ø 277 | a :< as -> (:<) <$> f a <*> traverse1 f as 278 | 279 | instance IxTraversable1 Index Prod where 280 | itraverse1 f = \case 281 | Ø -> pure Ø 282 | a :< as -> (:<) <$> f IZ a <*> itraverse1 (f . IS) as 283 | 284 | instance (Known Length as, Every (Known f) as) => Known (Prod f) as where 285 | type KnownC (Prod f) as = (Known Length as, Every (Known f) as) 286 | known = go known 287 | where 288 | go :: Every (Known f) xs => Length xs -> Prod f xs 289 | go = \case 290 | LZ -> Ø 291 | LS l -> known :< go l 292 | 293 | {- 294 | instance Known (Prod f) Ø where 295 | known = Ø 296 | 297 | instance (Known f a, Known (Prod f) as) => Known (Prod f) (a :< as) where 298 | type KnownC (Prod f) (a :< as) = (Known f a, Known (Prod f) as) 299 | known = known :< known 300 | -} 301 | 302 | type family Witnesses (ps :: [Constraint]) (qs :: [Constraint]) (f :: k -> *) (as :: [k]) :: Constraint where 303 | Witnesses Ø Ø f Ø = ØC 304 | Witnesses (p :< ps) (q :< qs) f (a :< as) = (Witness p q (f a), Witnesses ps qs f as) 305 | 306 | instance Witness ØC ØC (Prod f Ø) where 307 | r \\ _ = r 308 | 309 | instance (Witness p q (f a), Witness s t (Prod f as)) => Witness (p,s) (q,t) (Prod f (a :< as)) where 310 | type WitnessC (p,s) (q,t) (Prod f (a :< as)) = (Witness p q (f a), Witness s t (Prod f as)) 311 | r \\ (a :< as) = r \\ a \\ as 312 | 313 | toList :: (forall a. f a -> r) -> Prod f as -> [r] 314 | toList f = \case 315 | Ø -> [] 316 | a :< as -> f a : toList f as 317 | 318 | -------------------------------------------------------------------------------- /src/Data/Type/Combinator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE DefaultSignatures #-} 7 | {-# LANGUAGE PatternSynonyms #-} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE LambdaCase #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# LANGUAGE KindSignatures #-} 17 | {-# LANGUAGE DataKinds #-} 18 | {-# LANGUAGE PolyKinds #-} 19 | {-# LANGUAGE GADTs #-} 20 | ----------------------------------------------------------------------------- 21 | -- | 22 | -- Module : Data.Type.Combinator 23 | -- Copyright : Copyright (C) 2015 Kyle Carter 24 | -- License : BSD3 25 | -- 26 | -- Maintainer : Kyle Carter 27 | -- Stability : experimental 28 | -- Portability : RankNTypes 29 | -- 30 | -- A collection of simple type combinators, 31 | -- such as @Identity@ 'I', @Constant@ 'C', @Compose@ '(:.:)', 32 | -- Currying/Uncurrying, etc. 33 | -- 34 | ----------------------------------------------------------------------------- 35 | 36 | module Data.Type.Combinator where 37 | 38 | -- import Data.Type.Quantifier 39 | import Type.Class.Higher 40 | import Type.Class.Known 41 | import Type.Class.Witness 42 | import Type.Family.Tuple 43 | 44 | import Control.Applicative 45 | 46 | data Comp1 (f :: l -> m -> *) (g :: k -> l) :: k -> m -> * where 47 | Comp1 :: { getComp1 :: !(f (g h) a) 48 | } 49 | -> Comp1 f g h a 50 | 51 | instance (Functor1 f, Functor1 g) => Functor1 (Comp1 (f :: (l -> *) -> m -> *) (g :: (k -> *) -> l -> *)) where 52 | map1 f (Comp1 a) = Comp1 $ map1 (map1 f) a 53 | 54 | {- 55 | instance (IxFunctor1 i f, IxFunctor1 j g) => IxFunctor1 (IxComp i j) (Comp1 (f :: (l -> *) -> m -> *) (g :: (k -> *) -> l -> *)) where 56 | imap1 f = Comp1 . imap1 (\i -> imap1 $ \j -> f $ IxComp i j) . getComp1 57 | -} 58 | 59 | -- (:.:) {{{ 60 | 61 | newtype ((f :: l -> *) :.: (g :: k -> l)) (a :: k) = Comp 62 | { getComp :: f (g a) 63 | } deriving 64 | ( Eq , Ord , Show , Read 65 | ) 66 | 67 | instance Eq1 f => Eq1 (f :.: g) where 68 | Comp a `eq1` Comp b = a `eq1` b 69 | 70 | instance Ord1 f => Ord1 (f :.: g) where 71 | Comp a `compare1` Comp b = a `compare1` b 72 | 73 | instance Show1 f => Show1 (f :.: g) where 74 | showsPrec1 d (Comp a) = showParen (d > 10) 75 | $ showString "Comp " 76 | . showsPrec1 11 a 77 | 78 | instance Witness p q (f (g a)) => Witness p q ((f :.: g) a) where 79 | type WitnessC p q ((f :.: g) a) = Witness p q (f (g a)) 80 | r \\ Comp a = r \\ a 81 | 82 | instance TestEquality f => TestEquality (f :.: g) where 83 | testEquality (Comp a) (Comp b) = a =?= b //? qed 84 | 85 | instance TestEquality f => TestEquality1 ((:.:) f) where 86 | testEquality1 (Comp a) (Comp b) = a =?= b //? qed 87 | 88 | -- }}} 89 | 90 | -- I {{{ 91 | 92 | newtype I a = I 93 | { getI :: a 94 | } deriving 95 | ( Eq , Ord , Show 96 | , Functor , Foldable , Traversable 97 | ) 98 | 99 | instance Applicative I where 100 | pure = I 101 | I f <*> I a = I $ f a 102 | 103 | instance Monad I where 104 | I a >>= f = f a 105 | 106 | instance Witness p q a => Witness p q (I a) where 107 | type WitnessC p q (I a) = Witness p q a 108 | r \\ I a = r \\ a 109 | 110 | instance Num a => Num (I a) where 111 | (*) = liftA2 (*) 112 | (+) = liftA2 (+) 113 | (-) = liftA2 (-) 114 | abs = fmap abs 115 | signum = fmap signum 116 | fromInteger = pure . fromInteger 117 | 118 | -- }}} 119 | 120 | -- C {{{ 121 | 122 | newtype C r a = C 123 | { getC :: r 124 | } deriving 125 | ( Eq , Ord , Show , Read 126 | , Functor , Foldable , Traversable 127 | ) 128 | 129 | instance Eq r => Eq1 (C r) 130 | instance Ord r => Ord1 (C r) 131 | instance Show r => Show1 (C r) 132 | 133 | instance Read r => Read1 (C r) where 134 | readsPrec1 d = readParen (d > 10) $ \s0 -> 135 | [ (Some $ C r,s2) 136 | | ("C",s1) <- lex s0 137 | , (r,s2) <- readsPrec 11 s1 138 | ] 139 | 140 | instance Witness p q r => Witness p q (C r a) where 141 | type WitnessC p q (C r a) = Witness p q r 142 | r \\ C a = r \\ a 143 | 144 | instance Num r => Num (C r a) where 145 | C a * C b = C $ a * b 146 | C a + C b = C $ a + b 147 | C a - C b = C $ a - b 148 | abs (C a) = C $ abs a 149 | signum (C a) = C $ signum a 150 | fromInteger = C . fromInteger 151 | 152 | mapC :: (r -> s) -> C r a -> C s b 153 | mapC f = C . f . getC 154 | 155 | -- }}} 156 | 157 | -- Flip {{{ 158 | 159 | newtype Flip p b a = Flip 160 | { getFlip :: p a b 161 | } deriving 162 | ( Eq , Ord , Show , Read 163 | ) 164 | 165 | flipTestEquality1 :: TestEquality (p c) => Flip p a c -> Flip p b c -> Maybe (a :~: b) 166 | flipTestEquality1 (Flip a) (Flip b) = a =?= b 167 | 168 | instance TestEquality1 p => TestEquality (Flip p b) where 169 | testEquality (Flip a) (Flip b) = a =??= b 170 | 171 | instance Witness p q (f a b) => Witness p q (Flip f b a) where 172 | type WitnessC p q (Flip f b a) = Witness p q (f a b) 173 | r \\ Flip a = r \\ a 174 | 175 | instance Known (p a) b => Known (Flip p b) a where 176 | type KnownC (Flip p b) a = Known (p a) b 177 | known = Flip known 178 | 179 | mapFlip :: (f a b -> g c d) -> Flip f b a -> Flip g d c 180 | mapFlip f = Flip . f . getFlip 181 | 182 | -- }}} 183 | 184 | -- Cur {{{ 185 | 186 | newtype Cur (p :: (k,l) -> *) (a :: k) (b :: l) = Cur 187 | { getCur :: p (a#b) 188 | } 189 | 190 | deriving instance Eq (p (a#b)) => Eq (Cur p a b) 191 | deriving instance Ord (p (a#b)) => Ord (Cur p a b) 192 | deriving instance Show (p (a#b)) => Show (Cur p a b) 193 | deriving instance Read (p (a#b)) => Read (Cur p a b) 194 | 195 | instance Known p (a#b) => Known (Cur p a) b where 196 | type KnownC (Cur p a) b = Known p (a#b) 197 | known = Cur known 198 | 199 | instance Witness q r (p (a#b)) => Witness q r (Cur p a b) where 200 | type WitnessC q r (Cur p a b) = Witness q r (p (a#b)) 201 | r \\ Cur p = r \\ p 202 | 203 | mapCur :: (p '(a,b) -> q '(c,d)) -> Cur p a b -> Cur q c d 204 | mapCur f = Cur . f . getCur 205 | 206 | -- }}} 207 | 208 | -- Uncur {{{ 209 | 210 | data Uncur (p :: k -> l -> *) :: (k,l) -> * where 211 | Uncur :: { getUncur :: p a b } -> Uncur p (a#b) 212 | 213 | deriving instance Eq (p (Fst x) (Snd x)) => Eq (Uncur p x) 214 | deriving instance Ord (p (Fst x) (Snd x)) => Ord (Uncur p x) 215 | deriving instance Show (p (Fst x) (Snd x)) => Show (Uncur p x) 216 | deriving instance (x ~ (a#b), Read (p a b)) => Read (Uncur p x) 217 | 218 | instance Read2 p => Read1 (Uncur p) where 219 | readsPrec1 d = readParen (d > 10) $ \s0 -> 220 | [ (p >>-- Some . Uncur,s2) 221 | | ("Uncur",s1) <- lex s0 222 | , (p,s2) <- readsPrec2 11 s1 223 | ] 224 | 225 | instance (Known (p a) b,q ~ (a#b)) => Known (Uncur p) q where 226 | type KnownC (Uncur p) q = Known (p (Fst q)) (Snd q) 227 | known = Uncur known 228 | 229 | instance (Witness r s (p a b),q ~ (a#b)) => Witness r s (Uncur p q) where 230 | type WitnessC r s (Uncur p q) = Witness r s (p (Fst q) (Snd q)) 231 | r \\ Uncur p = r \\ p 232 | 233 | mapUncur :: (p (Fst a) (Snd a) -> q b c) -> Uncur p a -> Uncur q '(b,c) 234 | mapUncur f (Uncur a) = Uncur $ f a 235 | 236 | -- }}} 237 | 238 | -- Cur3 {{{ 239 | 240 | newtype Cur3 (p :: (k,l,m) -> *) (a :: k) (b :: l) (c :: m) = Cur3 241 | { getCur3 :: p '(a,b,c) 242 | } 243 | 244 | deriving instance Eq (p '(a,b,c)) => Eq (Cur3 p a b c) 245 | deriving instance Ord (p '(a,b,c)) => Ord (Cur3 p a b c) 246 | deriving instance Show (p '(a,b,c)) => Show (Cur3 p a b c) 247 | deriving instance Read (p '(a,b,c)) => Read (Cur3 p a b c) 248 | 249 | instance Known p '(a,b,c) => Known (Cur3 p a b) c where 250 | type KnownC (Cur3 p a b) c = Known p '(a,b,c) 251 | known = Cur3 known 252 | 253 | instance Witness q r (p '(a,b,c)) => Witness q r (Cur3 p a b c) where 254 | type WitnessC q r (Cur3 p a b c) = Witness q r (p '(a,b,c)) 255 | r \\ Cur3 p = r \\ p 256 | 257 | mapCur3 :: (p '(a,b,c) -> q '(d,e,f)) -> Cur3 p a b c -> Cur3 q d e f 258 | mapCur3 f = Cur3 . f . getCur3 259 | 260 | -- }}} 261 | 262 | -- Uncur3 {{{ 263 | 264 | data Uncur3 (p :: k -> l -> m -> *) :: (k,l,m) -> * where 265 | Uncur3 :: { getUncur3 :: p a b c } -> Uncur3 p '(a,b,c) 266 | 267 | deriving instance Eq (p (Fst3 x) (Snd3 x) (Thd3 x)) => Eq (Uncur3 p x) 268 | deriving instance Ord (p (Fst3 x) (Snd3 x) (Thd3 x)) => Ord (Uncur3 p x) 269 | deriving instance Show (p (Fst3 x) (Snd3 x) (Thd3 x)) => Show (Uncur3 p x) 270 | deriving instance (x ~ '(a,b,c), Read (p a b c)) => Read (Uncur3 p x) 271 | 272 | instance Read3 p => Read1 (Uncur3 p) where 273 | readsPrec1 d = readParen (d > 10) $ \s0 -> 274 | [ (p >>--- Some . Uncur3,s2) 275 | | ("Uncur",s1) <- lex s0 276 | , (p,s2) <- readsPrec3 11 s1 277 | ] 278 | 279 | instance (Known (p a b) c,q ~ '(a,b,c)) => Known (Uncur3 p) q where 280 | type KnownC (Uncur3 p) q = Known (p (Fst3 q) (Snd3 q)) (Thd3 q) 281 | known = Uncur3 known 282 | 283 | instance (Witness r s (p a b c),q ~ '(a,b,c)) => Witness r s (Uncur3 p q) where 284 | type WitnessC r s (Uncur3 p q) = Witness r s (p (Fst3 q) (Snd3 q) (Thd3 q)) 285 | r \\ Uncur3 p = r \\ p 286 | 287 | mapUncur3 :: (p (Fst3 x) (Snd3 x) (Thd3 x) -> q d e f) -> Uncur3 p x -> Uncur3 q '(d,e,f) 288 | mapUncur3 f (Uncur3 a) = Uncur3 $ f a 289 | 290 | -- }}} 291 | 292 | -- Join {{{ 293 | 294 | newtype Join f a = Join 295 | { getJoin :: f a a 296 | } 297 | 298 | deriving instance Eq (f a a) => Eq (Join f a) 299 | deriving instance Ord (f a a) => Ord (Join f a) 300 | deriving instance Show (f a a) => Show (Join f a) 301 | deriving instance Read (f a a) => Read (Join f a) 302 | 303 | instance Eq2 f => Eq1 (Join f) where 304 | Join a `eq1` Join b = a `eq2` b 305 | 306 | instance Ord2 f => Ord1 (Join f) where 307 | Join a `compare1` Join b = a `compare2` b 308 | 309 | instance Show2 f => Show1 (Join f) where 310 | showsPrec1 d (Join a) = showParen (d > 10) 311 | $ showString "Join " 312 | . showsPrec2 11 a 313 | 314 | instance Known (f a) a => Known (Join f) a where 315 | type KnownC (Join f) a = Known (f a) a 316 | known = Join known 317 | 318 | instance Witness p q (f a a) => Witness p q (Join f a) where 319 | type WitnessC p q (Join f a) = Witness p q (f a a) 320 | r \\ Join a = r \\ a 321 | 322 | mapJoin :: (f a a -> g b b) -> Join f a -> Join g b 323 | mapJoin f = Join . f . getJoin 324 | 325 | -- }}} 326 | 327 | data Conj (t :: (k -> *) -> l -> *) (f :: k -> m -> *) :: l -> m -> * where 328 | Conj :: t (Flip f b) a 329 | -> Conj t f a b 330 | 331 | {- 332 | data Conj2 (t :: (k -> l -> *) -> m -> n -> *) (f :: k -> l -> o -> *) :: m -> n -> o -> * where 333 | Conj2 :: t 334 | -> Conj2 t f a b c 335 | -} 336 | 337 | data LL (c :: k -> *) :: l -> (l -> k) -> * where 338 | LL :: { getLL :: c (f a) 339 | } 340 | -> LL c a f 341 | 342 | data RR (c :: k -> *) :: (l -> k) -> l -> * where 343 | RR :: { getRR :: c (f a) } 344 | -> RR c f a 345 | 346 | -------------------------------------------------------------------------------- /src/Type/Class/Higher.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE GADTs #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Type.Class.Higher 18 | -- Copyright : Copyright (C) 2015 Kyle Carter 19 | -- License : BSD3 20 | -- 21 | -- Maintainer : Kyle Carter 22 | -- Stability : experimental 23 | -- Portability : RankNTypes 24 | -- 25 | -- Higher order analogs of type classes from the Prelude, 26 | -- and quantifier data types. 27 | ---------------------------------------------------------------------------- 28 | 29 | module Type.Class.Higher where 30 | 31 | import Type.Class.Witness 32 | import Type.Family.Constraint 33 | import Data.Maybe (fromMaybe) 34 | 35 | -- EqN {{{ 36 | 37 | class Eq1 (f :: k -> *) where 38 | eq1 :: f a -> f a -> Bool 39 | default eq1 :: Eq (f a) => f a -> f a -> Bool 40 | eq1 = (==) 41 | neq1 :: f a -> f a -> Bool 42 | neq1 a b = not $ eq1 a b 43 | 44 | (=#=) :: Eq1 f => f a -> f a -> Bool 45 | (=#=) = eq1 46 | infix 4 =#= 47 | 48 | class Eq2 (f :: k -> l -> *) where 49 | eq2 :: f a b -> f a b -> Bool 50 | default eq2 :: Eq (f a b) => f a b -> f a b -> Bool 51 | eq2 = (==) 52 | neq2 :: f a b -> f a b -> Bool 53 | neq2 a b = not $ eq2 a b 54 | 55 | (=##=) :: Eq2 f => f a b -> f a b -> Bool 56 | (=##=) = eq2 57 | infix 4 =##= 58 | 59 | class Eq3 (f :: k -> l -> m -> *) where 60 | eq3 :: f a b c -> f a b c -> Bool 61 | default eq3 :: Eq (f a b c ) => f a b c -> f a b c -> Bool 62 | eq3 = (==) 63 | neq3 :: f a b c -> f a b c -> Bool 64 | neq3 a b = not $ eq3 a b 65 | 66 | (=###=) :: Eq3 f => f a b c -> f a b c -> Bool 67 | (=###=) = eq3 68 | infix 4 =###= 69 | 70 | -- }}} 71 | 72 | -- OrdN {{{ 73 | 74 | class Eq1 f => Ord1 (f :: k -> *) where 75 | compare1 :: f a -> f a -> Ordering 76 | default compare1 :: Ord (f a) => f a -> f a -> Ordering 77 | compare1 = compare 78 | (<#) :: f a -> f a -> Bool 79 | a <# b = compare1 a b == LT 80 | (>#) :: f a -> f a -> Bool 81 | a ># b = compare1 a b == GT 82 | (<=#) :: f a -> f a -> Bool 83 | a <=# b = compare1 a b /= GT 84 | (>=#) :: f a -> f a -> Bool 85 | a >=# b = compare1 a b /= LT 86 | infix 4 <#, >#, <=#, >=# 87 | 88 | class Eq2 f => Ord2 (f :: k -> l -> *) where 89 | compare2 :: f a b -> f a b -> Ordering 90 | default compare2 :: Ord (f a b) => f a b -> f a b -> Ordering 91 | compare2 = compare 92 | (<##) :: f a b -> f a b -> Bool 93 | a <## b = compare2 a b == LT 94 | (>##) :: f a b -> f a b -> Bool 95 | a >## b = compare2 a b == GT 96 | (<=##) :: f a b -> f a b -> Bool 97 | a <=## b = compare2 a b /= GT 98 | (>=##) :: f a b -> f a b -> Bool 99 | a >=## b = compare2 a b /= LT 100 | infix 4 <##, >##, <=##, >=## 101 | 102 | class Eq3 f => Ord3 (f :: k -> l -> m -> *) where 103 | compare3 :: f a b c -> f a b c -> Ordering 104 | default compare3 :: Ord (f a b c) => f a b c -> f a b c -> Ordering 105 | compare3 = compare 106 | (<###) :: f a b c -> f a b c -> Bool 107 | a <### b = compare3 a b == LT 108 | (>###) :: f a b c -> f a b c -> Bool 109 | a >### b = compare3 a b == GT 110 | (<=###) :: f a b c -> f a b c -> Bool 111 | a <=### b = compare3 a b /= GT 112 | (>=###) :: f a b c -> f a b c -> Bool 113 | a >=### b = compare3 a b /= LT 114 | infix 4 <###, >###, <=###, >=### 115 | 116 | -- }}} 117 | 118 | -- ShowN {{{ 119 | 120 | class Show1 (f :: k -> *) where 121 | showsPrec1 :: Int -> f a -> ShowS 122 | default showsPrec1 :: Show (f a) => Int -> f a -> ShowS 123 | showsPrec1 = showsPrec 124 | show1 :: f a -> String 125 | show1 = ($ "") . shows1 126 | 127 | shows1 :: Show1 f => f a -> ShowS 128 | shows1 = showsPrec1 0 129 | 130 | class Show2 (f :: k -> l -> *) where 131 | showsPrec2 :: Int -> f a b -> ShowS 132 | default showsPrec2 :: Show (f a b) => Int -> f a b -> ShowS 133 | showsPrec2 = showsPrec 134 | show2 :: f a b -> String 135 | show2 = ($ "") . shows2 136 | 137 | shows2 :: Show2 f => f a b -> ShowS 138 | shows2 = showsPrec2 0 139 | 140 | class Show3 (f :: k -> l -> m -> *) where 141 | showsPrec3 :: Int -> f a b c -> ShowS 142 | default showsPrec3 :: Show (f a b c) => Int -> f a b c -> ShowS 143 | showsPrec3 = showsPrec 144 | show3 :: f a b c -> String 145 | show3 = ($ "") . shows3 146 | 147 | shows3 :: Show3 f => f a b c -> ShowS 148 | shows3 = showsPrec3 0 149 | 150 | -- }}} 151 | 152 | -- ReadN {{{ 153 | 154 | class Read1 (f :: k -> *) where 155 | readsPrec1 :: Int -> ReadS (Some f) 156 | 157 | reads1 :: Read1 f => ReadS (Some f) 158 | reads1 = readsPrec1 0 159 | 160 | readMaybe1 :: Read1 f => String -> Maybe (Some f) 161 | readMaybe1 s = case reads1 s of 162 | [(f,"")] -> Just f 163 | _ -> Nothing 164 | 165 | 166 | class Read2 (f :: k -> l -> *) where 167 | readsPrec2 :: Int -> ReadS (Some2 f) 168 | 169 | reads2 :: Read2 f => ReadS (Some2 f) 170 | reads2 = readsPrec2 0 171 | 172 | readMaybe2 :: Read2 f => String -> Maybe (Some2 f) 173 | readMaybe2 s = case reads2 s of 174 | [(f,"")] -> Just f 175 | _ -> Nothing 176 | 177 | 178 | class Read3 (f :: k -> l -> m -> *) where 179 | readsPrec3 :: Int -> ReadS (Some3 f) 180 | 181 | reads3 :: Read3 f => ReadS (Some3 f) 182 | reads3 = readsPrec3 0 183 | 184 | readMaybe3 :: Read3 f => String -> Maybe (Some3 f) 185 | readMaybe3 s = case reads3 s of 186 | [(f,"")] -> Just f 187 | _ -> Nothing 188 | 189 | -- }}} 190 | 191 | -- FunctorN {{{ 192 | 193 | class Functor1 (t :: (k -> *) -> l -> *) where 194 | -- | Take a natural transformation to a lifted natural transformation. 195 | map1 :: (forall (a :: k). f a -> g a) -> t f b -> t g b 196 | 197 | class IxFunctor1 (i :: l -> k -> *) (t :: (k -> *) -> l -> *) | t -> i where 198 | imap1 :: (forall (a :: k). i b a -> f a -> g a) -> t f b -> t g b 199 | 200 | -- }}} 201 | 202 | -- FoldableN {{{ 203 | 204 | class Foldable1 (t :: (k -> *) -> l -> *) where 205 | foldMap1 :: Monoid m => (forall (a :: k). f a -> m) -> t f b -> m 206 | 207 | class IxFoldable1 (i :: l -> k -> *) (t :: (k -> *) -> l -> *) | t -> i where 208 | ifoldMap1 :: Monoid m => (forall (a :: k). i b a -> f a -> m) -> t f b -> m 209 | 210 | -- }}} 211 | 212 | -- TraversableN {{{ 213 | 214 | class (Functor1 t, Foldable1 t) => Traversable1 (t :: (k -> *) -> l -> *) where 215 | traverse1 :: Applicative h => (forall (a :: k). f a -> h (g a)) -> t f b -> h (t g b) 216 | 217 | class (IxFunctor1 i t, IxFoldable1 i t) => IxTraversable1 (i :: l -> k -> *) (t :: (k -> *) -> l -> *) | t -> i where 218 | itraverse1 :: Applicative h => (forall (a :: k). i b a -> f a -> h (g a)) -> t f b -> h (t g b) 219 | 220 | -- }}} 221 | 222 | -- BifunctorN {{{ 223 | 224 | class Bifunctor1 (t :: (k -> *) -> (l -> *) -> m -> *) where 225 | bimap1 :: (forall (a :: k). f a -> h a) 226 | -> (forall (a :: l). g a -> i a) 227 | -> t f g b 228 | -> t h i b 229 | 230 | class IxBifunctor1 (i :: m -> k -> *) (j :: m -> l -> *) (t :: (k -> *) -> (l -> *) -> m -> *) | t -> i j where 231 | ibimap1 :: (forall (a :: k). i b a -> f a -> f' a) 232 | -> (forall (a :: l). j b a -> g a -> g' a) 233 | -> t f g b 234 | -> t f' g' b 235 | 236 | -- }}} 237 | 238 | 239 | 240 | -- Some {{{ 241 | 242 | data Some (f :: k -> *) :: * where 243 | Some :: f a -> Some f 244 | 245 | instance (TestEquality f, Eq1 f) => Eq (Some f) where 246 | Some a == Some b = fromMaybe False $ testEquality a b //? return (eq1 a b) 247 | 248 | -- | An eliminator for a 'Some' type. 249 | -- 250 | -- Consider this function akin to a Monadic bind, except 251 | -- instead of binding into a Monad with a sequent function, 252 | -- we're binding into the existential quantification with 253 | -- a universal eliminator function. 254 | -- 255 | -- It serves as an explicit delimiter in a program of where 256 | -- the type index may be used and depended on, and where it may 257 | -- not. 258 | -- 259 | -- NB: the result type of the eliminating function may 260 | -- not refer to the universally quantified type index @a@. 261 | -- 262 | some :: Some f -> (forall a. f a -> r) -> r 263 | some (Some a) f = f a 264 | 265 | (>>-) :: Some f -> (forall a. f a -> r) -> r 266 | (>>-) = some 267 | infixl 1 >>- 268 | 269 | (>->) :: (forall x. f x -> Some g) -> (forall x. g x -> Some h) -> f a -> Some h 270 | (f >-> g) a = f a >>- g 271 | infixr 1 >-> 272 | 273 | withSome :: (forall a. f a -> r) -> Some f -> r 274 | withSome f (Some a) = f a 275 | 276 | onSome :: (forall a. f a -> g x) -> Some f -> Some g 277 | onSome f (Some a) = Some (f a) 278 | 279 | msome :: Monad m => f a -> m (Some f) 280 | msome = return . Some 281 | 282 | (>>=-) :: Monad m => m (Some f) -> (forall a. f a -> m r) -> m r 283 | m >>=- f = do 284 | s <- m 285 | s >>- f 286 | infixl 1 >>=- 287 | 288 | -- }}} 289 | 290 | -- Some2 {{{ 291 | 292 | data Some2 (f :: k -> l -> *) :: * where 293 | Some2 :: f a b -> Some2 f 294 | 295 | some2 :: Some2 f -> (forall a b. f a b -> r) -> r 296 | some2 (Some2 a) f = f a 297 | 298 | (>>--) :: Some2 f -> (forall a b. f a b -> r) -> r 299 | (>>--) = some2 300 | infixl 1 >>-- 301 | 302 | (>-->) :: (forall x y. f x y -> Some2 g) -> (forall x y. g x y -> Some2 h) -> f a b -> Some2 h 303 | (f >--> g) a = f a >>-- g 304 | infixr 1 >--> 305 | 306 | withSome2 :: (forall a b. f a b -> r) -> Some2 f -> r 307 | withSome2 f (Some2 a) = f a 308 | 309 | onSome2 :: (forall a b. f a b -> g x y) -> Some2 f -> Some2 g 310 | onSome2 f (Some2 a) = Some2 (f a) 311 | 312 | msome2 :: Monad m => f a b -> m (Some2 f) 313 | msome2 = return . Some2 314 | 315 | (>>=--) :: Monad m => m (Some2 f) -> (forall a b. f a b -> m r) -> m r 316 | m >>=-- f = do 317 | s <- m 318 | s >>-- f 319 | infixl 1 >>=-- 320 | 321 | -- }}} 322 | 323 | -- Some3 {{{ 324 | 325 | data Some3 (f :: k -> l -> m -> *) :: * where 326 | Some3 :: f a b c -> Some3 f 327 | 328 | some3 :: Some3 f -> (forall a b c. f a b c -> r) -> r 329 | some3 (Some3 a) f = f a 330 | 331 | (>>---) :: Some3 f -> (forall a b c. f a b c -> r) -> r 332 | (>>---) = some3 333 | infixl 1 >>--- 334 | 335 | (>--->) :: (forall x y z. f x y z -> Some3 g) -> (forall x y z. g x y z -> Some3 h) -> f a b c -> Some3 h 336 | (f >---> g) a = f a >>--- g 337 | infixr 1 >---> 338 | 339 | withSome3 :: (forall a b c. f a b c -> r) -> Some3 f -> r 340 | withSome3 f (Some3 a) = f a 341 | 342 | onSome3 :: (forall a b c. f a b c -> g x y z) -> Some3 f -> Some3 g 343 | onSome3 f (Some3 a) = Some3 (f a) 344 | 345 | msome3 :: Monad m => f a b c -> m (Some3 f) 346 | msome3 = return . Some3 347 | 348 | (>>=---) :: Monad m => m (Some3 f) -> (forall a b c. f a b c -> m r) -> m r 349 | m >>=--- f = do 350 | s <- m 351 | s >>--- f 352 | infixl 1 >>=--- 353 | 354 | -- }}} 355 | 356 | -- SomeC {{{ 357 | 358 | data SomeC (c :: k -> Constraint) (f :: k -> *) where 359 | SomeC :: c a => f a -> SomeC c f 360 | 361 | someC :: SomeC c f -> (forall a. c a => f a -> r) -> r 362 | someC (SomeC a) f = f a 363 | 364 | (>>~) :: SomeC c f -> (forall a. c a => f a -> r) -> r 365 | (>>~) = someC 366 | infixl 1 >>~ 367 | 368 | msomeC :: (Monad m, c a) => f a -> m (SomeC c f) 369 | msomeC = return . SomeC 370 | 371 | (>>=~) :: Monad m => m (SomeC c f) -> (forall a. c a => f a -> m r) -> m r 372 | m >>=~ f = do 373 | s <- m 374 | s >>~ f 375 | infixl 1 >>=~ 376 | 377 | -- }}} 378 | 379 | {- 380 | -- EveryN {{{ 381 | 382 | data Every (f :: k -> *) :: * where 383 | Every :: { instEvery :: forall a. f a } -> Every f 384 | 385 | data Every2 (f :: k -> l -> *) :: * where 386 | Every2 :: { instEvery2 :: forall a b. f a b } -> Every2 f 387 | 388 | data Every3 (f :: k -> l -> m -> *) :: * where 389 | Every3 :: { instEvery3 :: forall a b c. f a b c } -> Every3 f 390 | 391 | data EveryC (c :: k -> Constraint) (f :: k -> *) :: * where 392 | EveryC :: { instEveryC :: forall a. c a => f a } 393 | -> EveryC c f 394 | 395 | -- }}} 396 | -} 397 | 398 | -------------------------------------------------------------------------------- /src/Data/Type/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE ConstraintKinds #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE LambdaCase #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE KindSignatures #-} 15 | {-# LANGUAGE DataKinds #-} 16 | {-# LANGUAGE PolyKinds #-} 17 | {-# LANGUAGE GADTs #-} 18 | ----------------------------------------------------------------------------- 19 | -- | 20 | -- Module : Data.Type.Vector 21 | -- Copyright : Copyright (C) 2015 Kyle Carter 22 | -- License : BSD3 23 | -- 24 | -- Maintainer : Kyle Carter 25 | -- Stability : experimental 26 | -- Portability : RankNTypes 27 | -- 28 | -- 'Vec' and its combinator analog 'VecT' represent lists 29 | -- of known length, characterized by the index @(n :: N)@ in 30 | -- @'Vec' n a@ or @'VecT' n f a@. 31 | -- 32 | -- The classic example used ad nauseum for type-level programming. 33 | -- 34 | -- The operations on 'Vec' and 'VecT' correspond to the type level arithmetic 35 | -- operations on the kind 'N'. 36 | -- 37 | ----------------------------------------------------------------------------- 38 | 39 | module Data.Type.Vector where 40 | 41 | import Data.Type.Combinator 42 | import Data.Type.Fin 43 | import Data.Type.Length 44 | import Data.Type.Nat 45 | import Data.Type.Product (Prod(..),curry',pattern (:>)) 46 | 47 | import Type.Class.Higher 48 | import Type.Class.Known 49 | import Type.Class.Witness 50 | 51 | import Type.Family.Constraint 52 | import Type.Family.List 53 | import Type.Family.Nat 54 | 55 | import qualified Data.List as L 56 | import Data.Monoid 57 | 58 | data VecT (n :: N) (f :: k -> *) :: k -> * where 59 | ØV :: VecT Z f a 60 | (:*) :: !(f a) -> !(VecT n f a) -> VecT (S n) f a 61 | infixr 4 :* 62 | 63 | (*:) :: f a -> f a -> VecT (S (S Z)) f a 64 | a *: b = a :* b :* ØV 65 | infix 5 *: 66 | 67 | elimVecT :: p Z 68 | -> (forall x. f a -> p x -> p (S x)) 69 | -> VecT n f a 70 | -> p n 71 | elimVecT z s = \case 72 | ØV -> z 73 | a :* as -> s a $ elimVecT z s as 74 | 75 | elimV :: p Z 76 | -> (forall x. a -> p x -> p (S x)) 77 | -> Vec n a 78 | -> p n 79 | elimV z s = elimVecT z $ s . getI 80 | 81 | type Vec n = VecT n I 82 | 83 | pattern (:+) :: a -> Vec n a -> Vec (S n) a 84 | pattern a :+ as = I a :* as 85 | infixr 4 :+ 86 | 87 | (+:) :: a -> a -> Vec (S (S Z)) a 88 | a +: b = a :+ b :+ ØV 89 | infix 5 +: 90 | 91 | deriving instance Eq (f a) => Eq (VecT n f a) 92 | deriving instance Ord (f a) => Ord (VecT n f a) 93 | deriving instance Show (f a) => Show (VecT n f a) 94 | 95 | (.++) :: VecT x f a -> VecT y f a -> VecT (x + y) f a 96 | (.++) = \case 97 | ØV -> id 98 | a :* as -> (a :*) . (as .++) 99 | infixr 5 .++ 100 | 101 | vrep :: forall n f a. Known Nat n => f a -> VecT n f a 102 | vrep a = go (known :: Nat n) 103 | where 104 | go :: Nat x -> VecT x f a 105 | go = \case 106 | Z_ -> ØV 107 | S_ x -> a :* go x 108 | 109 | head' :: VecT (S n) f a -> f a 110 | head' (a :* _) = a 111 | 112 | tail' :: VecT (S n) f a -> VecT n f a 113 | tail' (_ :* as) = as 114 | 115 | onTail :: (VecT m f a -> VecT n f a) -> VecT (S m) f a -> VecT (S n) f a 116 | onTail f (a :* as) = a :* f as 117 | 118 | vDel :: Fin n -> VecT n f a -> VecT (Pred n) f a 119 | vDel = \case 120 | FZ -> tail' 121 | FS x -> onTail (vDel x) \\ x 122 | 123 | imap :: (Fin n -> f a -> g b) -> VecT n f a -> VecT n g b 124 | imap f = \case 125 | ØV -> ØV 126 | a :* as -> f FZ a :* imap (f . FS) as 127 | 128 | ifoldMap :: Monoid m => (Fin n -> f a -> m) -> VecT n f a -> m 129 | ifoldMap f = \case 130 | ØV -> mempty 131 | a :* as -> f FZ a <> ifoldMap (f . FS) as 132 | 133 | itraverse :: Applicative h => (Fin n -> f a -> h (g b)) -> VecT n f a -> h (VecT n g b) 134 | itraverse f = \case 135 | ØV -> pure ØV 136 | a :* as -> (:*) <$> f FZ a <*> itraverse (f . FS) as 137 | 138 | index :: Fin n -> VecT n f a -> f a 139 | index = \case 140 | FZ -> head' 141 | FS x -> index x . tail' 142 | 143 | index' :: Fin n -> Vec n a -> a 144 | index' i = getI . index i 145 | 146 | vmap :: (f a -> g b) -> VecT n f a -> VecT n g b 147 | vmap f = \case 148 | ØV -> ØV 149 | a :* as -> f a :* vmap f as 150 | 151 | vap :: (f a -> g b -> h c) -> VecT n f a -> VecT n g b -> VecT n h c 152 | vap f = \case 153 | ØV -> const ØV 154 | a :* as -> \case 155 | b :* bs -> f a b :* vap f as bs 156 | 157 | vfoldr :: (f a -> b -> b) -> b -> VecT n f a -> b 158 | vfoldr s z = \case 159 | ØV -> z 160 | a :* as -> s a $ vfoldr s z as 161 | 162 | vfoldMap' :: (b -> b -> b) -> b -> (f a -> b) -> VecT n f a -> b 163 | vfoldMap' j z f = \case 164 | ØV -> z 165 | a :* ØV -> f a 166 | a :* as -> j (f a) $ vfoldMap' j z f as 167 | 168 | vfoldMap :: Monoid m => (f a -> m) -> VecT n f a -> m 169 | vfoldMap f = \case 170 | ØV -> mempty 171 | a :* as -> f a <> vfoldMap f as 172 | 173 | withVecT :: [f a] -> (forall n. VecT n f a -> r) -> r 174 | withVecT as k = case as of 175 | [] -> k ØV 176 | a : as' -> withVecT as' $ \v -> k $ a :* v 177 | 178 | withV :: [a] -> (forall n. Vec n a -> r) -> r 179 | withV as = withVecT (I <$> as) 180 | 181 | findV :: Eq a => a -> Vec n a -> Maybe (Fin n) 182 | findV = findVecT . I 183 | 184 | findVecT :: Eq (f a) => f a -> VecT n f a -> Maybe (Fin n) 185 | findVecT a = \case 186 | ØV -> Nothing 187 | b :* as -> if a == b 188 | then Just FZ 189 | else FS <$> findVecT a as 190 | 191 | instance Functor1 (VecT n) where 192 | map1 f = \case 193 | ØV -> ØV 194 | a :* as -> f a :* map1 f as 195 | 196 | instance Foldable1 (VecT n) where 197 | foldMap1 f = \case 198 | ØV -> mempty 199 | a :* as -> f a <> foldMap1 f as 200 | 201 | instance Traversable1 (VecT n) where 202 | traverse1 f = \case 203 | ØV -> pure ØV 204 | a :* as -> (:*) <$> f a <*> traverse1 f as 205 | 206 | instance Functor f => Functor (VecT n f) where 207 | fmap = vmap . fmap 208 | 209 | instance (Applicative f, Known Nat n) => Applicative (VecT n f) where 210 | pure = vrep . pure 211 | (<*>) = vap (<*>) 212 | 213 | instance (Monad f, Known Nat n) => Monad (VecT n f) where 214 | v >>= f = imap (\x -> (>>= index x . f)) v 215 | 216 | instance Foldable f => Foldable (VecT n f) where 217 | foldMap f = \case 218 | ØV -> mempty 219 | a :* as -> foldMap f a <> foldMap f as 220 | 221 | instance Traversable f => Traversable (VecT n f) where 222 | traverse f = \case 223 | ØV -> pure ØV 224 | a :* as -> (:*) <$> traverse f a <*> traverse f as 225 | 226 | {- 227 | instance (Witness p q (f a), n ~ S x) => Witness p q (VecT n f a) where 228 | type WitnessC p q (VecT n f a) = Witness p q (f a) 229 | (\\) r = \case 230 | a :* _ -> r \\ a 231 | _ -> error "impossible type" 232 | -} 233 | 234 | instance Witness ØC (Known Nat n) (VecT n f a) where 235 | (\\) r = \case 236 | ØV -> r 237 | _ :* as -> r \\ as 238 | 239 | instance (Num (f a), Known Nat n) => Num (VecT n f a) where 240 | (*) = vap (*) 241 | (+) = vap (+) 242 | (-) = vap (-) 243 | negate = vmap negate 244 | abs = vmap abs 245 | signum = vmap signum 246 | fromInteger = vrep . fromInteger 247 | 248 | newtype M ns a = M { getMatrix :: Matrix ns a } 249 | 250 | deriving instance Eq (Matrix ns a) => Eq (M ns a) 251 | deriving instance Ord (Matrix ns a) => Ord (M ns a) 252 | deriving instance Show (Matrix ns a) => Show (M ns a) 253 | 254 | instance Num (Matrix ns a) => Num (M ns a) where 255 | fromInteger = M . fromInteger 256 | M a * M b = M $ a * b 257 | M a + M b = M $ a + b 258 | M a - M b = M $ a - b 259 | abs (M a) = M $ abs a 260 | signum (M a) = M $ signum a 261 | 262 | type family Matrix (ns :: [N]) :: * -> * where 263 | Matrix Ø = I 264 | Matrix (n :< ns) = VecT n (Matrix ns) 265 | 266 | vgen_ :: Known Nat n => (Fin n -> f a) -> VecT n f a 267 | vgen_ = vgen known 268 | 269 | vgen :: Nat n -> (Fin n -> f a) -> VecT n f a 270 | vgen x f = case x of 271 | Z_ -> ØV 272 | S_ y -> f FZ :* vgen y (f . FS) 273 | 274 | mgen_ :: Known (Prod Nat) ns => (Prod Fin ns -> a) -> M ns a 275 | mgen_ = mgen known 276 | 277 | mgen :: Prod Nat ns -> (Prod Fin ns -> a) -> M ns a 278 | mgen ns f = case ns of 279 | Ø -> M $ I $ f Ø 280 | n :< ns' -> M $ vgen n $ getMatrix . mgen ns' . curry' f 281 | 282 | onMatrix :: (Matrix ms a -> Matrix ns b) -> M ms a -> M ns b 283 | onMatrix f = M . f . getMatrix 284 | 285 | diagonal :: VecT n (VecT n f) a -> VecT n f a 286 | diagonal = imap index 287 | 288 | vtranspose :: Known Nat n => VecT m (VecT n f) a -> VecT n (VecT m f) a 289 | vtranspose v = vgen_ $ \x -> vmap (index x) v 290 | 291 | transpose :: Known Nat n => M (m :< n :< ns) a -> M (n :< m :< ns) a 292 | transpose = onMatrix vtranspose 293 | 294 | m0 :: M Ø Int 295 | m0 = 1 296 | 297 | m1 :: M '[N2] Int 298 | m1 = 2 299 | 300 | m2 :: M '[N2,N4] Int 301 | m2 = 3 302 | 303 | m3 :: M '[N2,N3,N4] (Int,Int,Int) 304 | m3 = mgen_ $ \(x :< y :> z) -> (fin x,fin y,fin z) 305 | 306 | m4 :: M '[N2,N3,N4,N5] (Int,Int,Int,Int) 307 | m4 = mgen_ $ \(w :< x :< y :> z) -> (fin w,fin x,fin y,fin z) 308 | 309 | ppVec :: (VecT n ((->) String) String -> ShowS) -> (f a -> ShowS) -> VecT n f a -> ShowS 310 | ppVec pV pF = pV . vmap pF 311 | 312 | ppMatrix :: forall ns a. (Show a, Known Length ns) => M ns a -> IO () 313 | ppMatrix = putStrLn . ($ "") . ppMatrix' (known :: Length ns) . getMatrix 314 | 315 | ppMatrix' :: Show a => Length ns -> Matrix ns a -> ShowS 316 | ppMatrix' = \case 317 | LZ -> shows . getI 318 | LS l -> ppVec 319 | ( vfoldMap' 320 | ( if lEven l 321 | then zipLines $ \x y -> x . showChar '|' . y 322 | else \x y -> x . showChar '\n' . y 323 | ) (showString "[]") id 324 | ) $ ppMatrix' l 325 | 326 | mzipWith :: Monoid a => (a -> a -> b) -> [a] -> [a] -> [b] 327 | mzipWith f as bs = case (as,bs) of 328 | ([] ,[] ) -> [] 329 | (a:as',[] ) -> f a mempty : mzipWith f as' [] 330 | ([] ,b:bs') -> f mempty b : mzipWith f [] bs' 331 | (a:as',b:bs') -> f a b : mzipWith f as' bs' 332 | 333 | zipLines :: (ShowS -> ShowS -> ShowS) -> ShowS -> ShowS -> ShowS 334 | zipLines f a b = compose $ L.intersperse (showChar '\n') $ mzipWith 335 | (\(Endo x) (Endo y) -> f x y) 336 | (Endo . showString <$> lines (a "")) 337 | (Endo . showString <$> lines (b "")) 338 | 339 | {- 340 | juxtLines :: (ShowS -> ShowS -> ShowS) -> ShowS -> ShowS -> ShowS 341 | juxtLines f a b = appEndo $ foldMap id $ mzip (\x y -> Endo $ f (appEndo x) (appEndo y)) as bs 342 | where 343 | as = map (Endo . showString) $ lines $ a "" 344 | bs = map (Endo . showString) $ lines $ b "" 345 | -} 346 | 347 | compose :: Foldable f => f (a -> a) -> a -> a 348 | compose = appEndo . foldMap Endo 349 | 350 | {- 351 | -- Linear {{{ 352 | 353 | class Functor f => Additive f where 354 | zero :: Num a => f a 355 | (^+^) :: Num a => f a -> f a -> f a 356 | (^-^) :: Num a => f a -> f a -> f a 357 | lerp :: Num a => a -> f a -> f a -> f a 358 | liftU2 :: (a -> a -> a) -> f a -> f a -> f a 359 | liftI2 :: (a -> b -> c) -> f a -> f b -> f c 360 | -------- 361 | default zero :: (Applicative f, Num a) => f a 362 | zero = pure 0 363 | (^+^) = liftU2 (+) 364 | a ^-^ b = a ^+^ negated b 365 | lerp alpha a b = alpha *^ a ^+^ (1 - alpha) *^ b 366 | default liftU2 :: Applicative f => (a -> a -> a) -> f a -> f a -> f a 367 | liftU2 = liftA2 368 | default liftI2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c 369 | liftI2 = liftA2 370 | infixl 6 ^+^, ^-^ 371 | 372 | instance Additive I 373 | instance (Additive f, Known Nat n) => Additive (VecT n f) where 374 | zero = vrep zero 375 | liftU2 = vap . liftU2 376 | liftI2 = vap . liftI2 377 | 378 | class Additive (Diff f) => Affine f where 379 | type Diff f :: * -> * 380 | type Diff f = f 381 | (.-.) :: Num a => f a -> f a -> Diff f a 382 | (.+^) :: Num a => f a -> Diff f a -> f a 383 | (.-^) :: Num a => f a -> Diff f a -> f a 384 | -------- 385 | p .-^ d = p .+^ negated d 386 | default (.-.) :: (Affine f, Diff f ~ f, Num a) => f a -> f a -> Diff f a 387 | (.-.) = (^-^) 388 | default (.+^) :: (Affine f, Diff f ~ f, Num a) => f a -> f a -> Diff f a 389 | (.+^) = (^+^) 390 | infixl 6 .-., .+^, .-^ 391 | 392 | instance Affine I 393 | instance (Affine f, Known Nat n) => Affine (VecT n f) where 394 | type Diff (VecT n f) = VecT n (Diff f) 395 | (.-.) = vap (.-.) 396 | (.+^) = vap (.+^) 397 | (.-^) = vap (.-^) 398 | 399 | class Additive f => Metric f where 400 | dot :: Num a => f a -> f a -> a 401 | quadrance :: Num a => f a -> a 402 | qd :: Num a => f a -> f a -> a 403 | distance :: Floating a => f a -> f a -> a 404 | norm :: Floating a => f a -> a 405 | signorm :: Floating a => f a -> f a 406 | -------- 407 | default dot :: (Foldable f, Num a) => f a -> f a -> a 408 | dot a b = F.sum $ liftI2 (*) a b 409 | quadrance = join dot 410 | qd a b = quadrance $ a ^-^ b 411 | distance a b = norm $ a ^-^ b 412 | norm = sqrt . quadrance 413 | signorm a = (/ norm a) <$> a 414 | 415 | instance Metric I where 416 | dot (I a) (I b) = a * b 417 | 418 | instance (Metric f, Known Nat n) => Metric (VecT n f) where 419 | dot a b = getSum $ foldMap Sum $ vap ((I .) . dot) a b 420 | 421 | (*^) :: (Functor f, Num a) => a -> f a -> f a 422 | (*^) a = fmap (a*) 423 | infixl 7 *^ 424 | 425 | negated :: (Functor f, Num a) => f a -> f a 426 | negated = fmap negate 427 | 428 | qdA :: (Affine f, Foldable (Diff f), Num a) => f a -> f a -> a 429 | qdA a b = F.sum $ join (*) <$> a .-. b 430 | 431 | distanceA :: (Affine f, Foldable (Diff f), Floating a) => f a -> f a -> a 432 | distanceA a b = sqrt $ qdA a b 433 | 434 | -- }}} 435 | -} 436 | 437 | --------------------------------------------------------------------------------