diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,23 @@ Changelog for singletons project ================================ +0.10.0 +------ + +Template Haskell names are now more hygienic. In other words, `singletons` +won't try to gobble up something happened to be named `Sing` in your project. +(Note that the Template Haskell names are not *completely* hygienic; names +generated during singleton generation can still cause conflicts.) + +If a function to be promoted or singletonized is missing a type signature, +that is now an *error*, not a warning. + +Added a new external module Data.Singletons.TypeLits, which contain the +singletons for GHC.TypeLits. Some convenience functions are also provided. + +The extension `EmptyCase` is no longer needed. This caused pain when trying +to support both GHC 7.6.3 and 7.8. + 0.9.3 ----- diff --git a/Data/Singletons.hs b/Data/Singletons.hs deleted file mode 100644 --- a/Data/Singletons.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE MagicHash, RankNTypes, PolyKinds, GADTs, DataKinds, - FlexibleContexts, CPP, TypeFamilies #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- This module exports the basic definitions to use singletons. For routine --- use, consider importing 'Data.Singletons.Prelude', which exports constructors --- for singletons based on types in the @Prelude@. --- --- You may also want to read --- and the --- original paper presenting this library, available at --- . --- ----------------------------------------------------------------------------- - -module Data.Singletons ( - -- * Main singleton definitions - - Sing, - -- | See also 'Data.Singletons.Prelude.Sing' for exported constructors - - SingI(..), SingKind(..), - - -- * Working with singletons - KindOf, Demote, - SingInstance(..), SomeSing(..), - singInstance, withSingI, withSomeSing, singByProxy, - -#if __GLASGOW_HASKELL__ >= 707 - singByProxy#, -#endif - withSing, singThat, - - -- * Auxiliary functions - bugInGHC, Error, sError, - KProxy(..), Proxy(..) - ) where - -import Data.Singletons.Core -import Unsafe.Coerce -import GHC.TypeLits (Symbol) - -#if __GLASGOW_HASKELL__ >= 707 -import GHC.Exts ( Proxy# ) -import Data.Proxy -#else -import Data.Singletons.Types -#endif - --- | A 'SingInstance' wraps up a 'SingI' instance for explicit handling. -data SingInstance (a :: k) where - SingInstance :: SingI a => SingInstance a - --- dirty implementation of explicit-to-implicit conversion -newtype DI a = Don'tInstantiate (SingI a => SingInstance a) - --- | Get an implicit singleton (a 'SingI' instance) from an explicit one. -singInstance :: forall (a :: k). Sing a -> SingInstance a -singInstance s = with_sing_i SingInstance - where - with_sing_i :: (SingI a => SingInstance a) -> SingInstance a - with_sing_i si = unsafeCoerce (Don'tInstantiate si) s - --- | Convenience function for creating a context with an implicit singleton --- available. -withSingI :: Sing n -> (SingI n => r) -> r -withSingI sn r = - case singInstance sn of - SingInstance -> r - --- | Convert a normal datatype (like 'Bool') to a singleton for that datatype, --- passing it into a continuation. -withSomeSing :: SingKind ('KProxy :: KProxy k) - => DemoteRep ('KProxy :: KProxy k) -- ^ The original datatype - -> (forall (a :: k). Sing a -> r) -- ^ Function expecting a singleton - -> r -withSomeSing x f = - case toSing x of - SomeSing x' -> f x' - --- | A convenience function useful when we need to name a singleton value --- multiple times. Without this function, each use of 'sing' could potentially --- refer to a different singleton, and one has to use type signatures (often --- with @ScopedTypeVariables@) to ensure that they are the same. -withSing :: SingI a => (Sing a -> b) -> b -withSing f = f sing - --- | A convenience function that names a singleton satisfying a certain --- property. If the singleton does not satisfy the property, then the function --- returns 'Nothing'. The property is expressed in terms of the underlying --- representation of the singleton. -singThat :: forall (a :: k). (SingKind ('KProxy :: KProxy k), SingI a) - => (Demote a -> Bool) -> Maybe (Sing a) -singThat p = withSing $ \x -> if p (fromSing x) then Just x else Nothing - --- | Allows creation of a singleton when a proxy is at hand. -singByProxy :: SingI a => proxy a -> Sing a -singByProxy _ = sing - -#if __GLASGOW_HASKELL__ >= 707 --- | Allows creation of a singleton when a @proxy#@ is at hand. -singByProxy# :: SingI a => Proxy# a -> Sing a -singByProxy# _ = sing -#endif - --- | GHC 7.8 sometimes warns about incomplete pattern matches when no such --- patterns are possible, due to GADT constraints. --- See the bug report at . --- In such cases, it's useful to have a catch-all pattern that then has --- 'bugInGHC' as its right-hand side. -bugInGHC :: forall a. a -bugInGHC = error "Bug encountered in GHC -- this should never happen" - --- | The promotion of 'error' -type family Error (str :: Symbol) :: k - --- | The singleton for 'error' -sError :: Sing (str :: Symbol) -> a -sError sstr = error (fromSing sstr) diff --git a/Data/Singletons/Bool.hs b/Data/Singletons/Bool.hs deleted file mode 100644 --- a/Data/Singletons/Bool.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds, TypeFamilies, TypeOperators, - GADTs, CPP #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Bool --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'Bool', --- including a singletons version of all the definitions in @Data.Bool@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Bool@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Bool ( - -- * The 'Bool' singleton - - Sing(SFalse, STrue), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SFalse :: Sing False - -- > STrue :: Sing True - - SBool, - -- | 'SBool' is a kind-restricted synonym for 'Sing': @type SBool (a :: Bool) = Sing a@ - - -- * Conditionals - If, sIf, - - -- * Singletons from @Data.Bool@ - Not, sNot, (:&&), (:||), (%:&&), (%:||), - - -- | The following are derived from the function 'bool' in @Data.Bool@. The extra - -- underscore is to avoid name clashes with the type 'Bool'. - Bool_, sBool_, Otherwise, sOtherwise - ) where - -import Data.Singletons.Core -import Data.Singletons.Singletons - -#if __GLASGOW_HASKELL__ >= 707 -import Data.Type.Bool - -type a :&& b = a && b -type a :|| b = a || b - -sNot :: SBool a -> SBool (Not a) -sNot SFalse = STrue -sNot STrue = SFalse - -(%:&&) :: SBool a -> SBool b -> SBool (a :&& b) -SFalse %:&& _ = SFalse -STrue %:&& a = a - -(%:||) :: SBool a -> SBool b -> SBool (a :|| b) -SFalse %:|| a = a -STrue %:|| _ = STrue - -#else - -$(singletonsOnly [d| - not :: Bool -> Bool - not False = True - not True = False - - (&&) :: Bool -> Bool -> Bool - False && _ = False - True && x = x - - (||) :: Bool -> Bool -> Bool - False || x = x - True || _ = True - |]) - --- | Type-level "If". @If True a b@ ==> @a@; @If False a b@ ==> @b@ -type family If (a :: Bool) (b :: k) (c :: k) :: k -type instance If 'True b c = b -type instance If 'False b c = c - -#endif - --- | Conditional over singletons -sIf :: Sing a -> Sing b -> Sing c -> Sing (If a b c) -sIf STrue b _ = b -sIf SFalse _ c = c - - --- ... with some functions over Booleans -$(singletonsOnly [d| - bool_ :: a -> a -> Bool -> a - bool_ fls _tru False = fls - bool_ _fls tru True = tru - - otherwise :: Bool - otherwise = True - |]) - diff --git a/Data/Singletons/Core.hs b/Data/Singletons/Core.hs deleted file mode 100644 --- a/Data/Singletons/Core.hs +++ /dev/null @@ -1,144 +0,0 @@ -{- Data/Singletons/Core.hs - -(c) Richard Eisenberg 2013 -eir@cis.upenn.edu - -This (internal) module contains the main class definitions for singletons, -re-exported from various places. - --} - -{-# LANGUAGE CPP, RankNTypes, DataKinds, PolyKinds, GADTs, TypeFamilies, - FlexibleContexts, TemplateHaskell, ScopedTypeVariables, - UndecidableInstances, TypeOperators, FlexibleInstances #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE EmptyCase #-} -#else - -- optimizing instances of SDecide cause GHC to die (#8467) -{-# OPTIONS_GHC -O0 #-} -#endif - -module Data.Singletons.Core where - -import Data.Singletons.Util -import Data.Singletons.Singletons -import GHC.TypeLits (Nat, Symbol) -import Data.Singletons.Types -import Unsafe.Coerce - -#if __GLASGOW_HASKELL__ >= 707 -import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) -import Data.Proxy -import Data.Type.Equality -#else -import qualified GHC.TypeLits as TypeLits -#endif - --- | Convenient synonym to refer to the kind of a type variable: --- @type KindOf (a :: k) = ('KProxy :: KProxy k)@ -type KindOf (a :: k) = ('KProxy :: KProxy k) - --- | The singleton kind-indexed data family. -data family Sing (a :: k) - --- | A 'SingI' constraint is essentially an implicitly-passed singleton. --- If you need to satisfy this constraint with an explicit singleton, please --- see 'withSingI'. -class SingI (a :: k) where - -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ - -- extension to use this method the way you want. - sing :: Sing a - --- | The 'SingKind' class is essentially a /kind/ class. It classifies all kinds --- for which singletons are defined. The class supports converting between a singleton --- type and the base (unrefined) type which it is built from. -class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where - -- | Get a base type from a proxy for the promoted kind. For example, - -- @DemoteRep ('KProxy :: KProxy Bool)@ will be the type @Bool@. - type DemoteRep kparam :: * - - -- | Convert a singleton to its unrefined version. - fromSing :: Sing (a :: k) -> DemoteRep kparam - - -- | Convert an unrefined type to an existentially-quantified singleton type. - toSing :: DemoteRep kparam -> SomeSing kparam - --- | Convenient abbreviation for 'DemoteRep': --- @type Demote (a :: k) = DemoteRep ('KProxy :: KProxy k)@ -type Demote (a :: k) = DemoteRep ('KProxy :: KProxy k) - --- | An /existentially-quantified/ singleton. This type is useful when you want a --- singleton type, but there is no way of knowing, at compile-time, what the type --- index will be. To make use of this type, you will generally have to use a --- pattern-match: --- --- > foo :: Bool -> ... --- > foo b = case toSing b of --- > SomeSing sb -> {- fancy dependently-typed code with sb -} --- --- An example like the one above may be easier to write using 'withSomeSing'. -data SomeSing (kproxy :: KProxy k) where - SomeSing :: Sing (a :: k) -> SomeSing ('KProxy :: KProxy k) - --- some useful singletons -$(genSingletons basicTypes) - --- define singletons for TypeLits - -newtype instance Sing (n :: Nat) = SNat Integer -#if __GLASGOW_HASKELL__ >= 707 -instance KnownNat n => SingI n where - sing = SNat (natVal (Proxy :: Proxy n)) -#else -instance TypeLits.SingRep n Integer => SingI (n :: Nat) where - sing = SNat (TypeLits.fromSing (TypeLits.sing :: TypeLits.Sing n)) -#endif -instance SingKind ('KProxy :: KProxy Nat) where - type DemoteRep ('KProxy :: KProxy Nat) = Integer - fromSing (SNat n) = n - toSing n = SomeSing (SNat n) - -newtype instance Sing (n :: Symbol) = SSym String -#if __GLASGOW_HASKELL__ >= 707 -instance KnownSymbol n => SingI n where - sing = SSym (symbolVal (Proxy :: Proxy n)) -#else -instance TypeLits.SingRep n String => SingI (n :: Symbol) where - sing = SSym (TypeLits.fromSing (TypeLits.sing :: TypeLits.Sing n)) -#endif -instance SingKind ('KProxy :: KProxy Symbol) where - type DemoteRep ('KProxy :: KProxy Symbol) = String - fromSing (SSym n) = n - toSing s = SomeSing (SSym s) - --- we need to decare SDecide and its instances here to avoid making --- the TestEquality instance an orphan - --- | Members of the 'SDecide' "kind" class support decidable equality. Instances --- of this class are generated alongside singleton definitions for datatypes that --- derive an 'Eq' instance. -class (kparam ~ 'KProxy) => SDecide (kparam :: KProxy k) where - -- | Compute a proof or disproof of equality, given two singletons. - (%~) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Decision (a :~: b) - -$(singDecideInstances basicTypes) - --- We need SDecide instances for the TypeLits singletons -instance SDecide ('KProxy :: KProxy Nat) where - (SNat n) %~ (SNat m) - | n == m = Proved $ unsafeCoerce Refl - | otherwise = Disproved (\_ -> error errStr) - where errStr = "Broken Nat singletons" - -instance SDecide ('KProxy :: KProxy Symbol) where - (SSym n) %~ (SSym m) - | n == m = Proved $ unsafeCoerce Refl - | otherwise = Disproved (\_ -> error errStr) - where errStr = "Broken Symbol singletons" - -instance SDecide ('KProxy :: KProxy k) => TestEquality (Sing :: k -> *) where - testEquality a b = - case a %~ b of - Proved Refl -> Just Refl - Disproved _ -> Nothing - diff --git a/Data/Singletons/CustomStar.hs b/Data/Singletons/CustomStar.hs deleted file mode 100644 --- a/Data/Singletons/CustomStar.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE DataKinds, TypeFamilies, KindSignatures, CPP, TemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.CustomStar --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- This file implements 'singletonStar', which generates a datatype @Rep@ and associated --- singleton from a list of types. The promoted version of @Rep@ is kind @*@ and the --- Haskell types themselves. This is still very experimental, so expect unusual --- results! --- ----------------------------------------------------------------------------- - -module Data.Singletons.CustomStar ( singletonStar ) where - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax ( Quasi(..) ) -import Data.Singletons.Util -import Data.Singletons.Promote -import Data.Singletons.Singletons -import Control.Monad - -#if __GLASGOW_HASKELL__ >= 707 -import Data.Singletons.Core -import Data.Singletons.Types -import Data.Singletons.Eq -import Unsafe.Coerce -import Data.Type.Equality -#endif - -{- -The SEq instance here is tricky. -The problem is that, in GHC 7.8+, the instance of type-level (==) for * -is not recursive. Thus, it's impossible, say, to get (Maybe a == Maybe b) ~ False -from (a == b) ~ False. - -There are a few ways forward: - 1) Define SEq to use our own Boolean (==) operator, instead of the built-in one. - This would work, but feels wrong. - 2) Use unsafeCoerce. -We do #2. - -Also to note: because these problems don't exist in GHC 7.6, the generation of -Eq and Decide for 7.6 is entirely normal. - -Note that mkCustomEqInstances makes the SDecide and SEq instances in GHC 7.8+, -but the type-level (==) instance in GHC 7.6. This is perhaps poor design, but -it reduces the amount of CPP noise. --} - --- | Produce a representation and singleton for the collection of types given. --- --- A datatype @Rep@ is created, with one constructor per type in the declared --- universe. When this type is promoted by the singletons library, the --- constructors become full types in @*@, not just promoted data constructors. --- --- For example, --- --- > $(singletonStar [''Nat, ''Bool, ''Maybe]) --- --- generates the following: --- --- > data Rep = Nat | Bool | Maybe Rep deriving (Eq, Show, Read) --- --- and its singleton. However, because @Rep@ is promoted to @*@, the singleton --- is perhaps slightly unexpected: --- --- > data instance Sing (a :: *) where --- > SNat :: Sing Nat --- > SBool :: Sing Bool --- > SMaybe :: SingRep a => Sing a -> Sing (Maybe a) --- --- The unexpected part is that @Nat@, @Bool@, and @Maybe@ above are the real @Nat@, --- @Bool@, and @Maybe@, not just promoted data constructors. --- --- Please note that this function is /very/ experimental. Use at your own risk. -singletonStar :: Quasi q - => [Name] -- ^ A list of Template Haskell @Name@s for types - -> q [Dec] -singletonStar names = do - kinds <- mapM getKind names - ctors <- zipWithM (mkCtor True) names kinds - let repDecl = DataD [] repName [] ctors - [''Eq, ''Show, ''Read] - fakeCtors <- zipWithM (mkCtor False) names kinds - eqInstances <- mkCustomEqInstances fakeCtors - singletonDecls <- singDataD True [] repName [] fakeCtors - [''Show, ''Read -#if __GLASGOW_HASKELL__ < 707 - , ''Eq -#endif - ] - return $ repDecl : - eqInstances ++ - singletonDecls - where -- get the kinds of the arguments to the tycon with the given name - getKind :: Quasi q => Name -> q [Kind] - getKind name = do - info <- reifyWithWarning name - case info of - TyConI (DataD (_:_) _ _ _ _) -> - fail "Cannot make a representation of a constrainted data type" - TyConI (DataD [] _ tvbs _ _) -> - return $ map extractTvbKind tvbs - TyConI (NewtypeD (_:_) _ _ _ _) -> - fail "Cannot make a representation of a constrainted newtype" - TyConI (NewtypeD [] _ tvbs _ _) -> - return $ map extractTvbKind tvbs - TyConI (TySynD _ tvbs _) -> - return $ map extractTvbKind tvbs - PrimTyConI _ n _ -> - return $ replicate n StarT - _ -> fail $ "Invalid thing for representation: " ++ (show name) - - -- first parameter is whether this is a real ctor (with a fresh name) - -- or a fake ctor (when the name is actually a Haskell type) - mkCtor :: Quasi q => Bool -> Name -> [Kind] -> q Con - mkCtor real name args = do - (types, vars) <- evalForPair $ mapM kindToType args - let ctor = NormalC ((if real then reinterpret else id) name) - (map (\ty -> (NotStrict, ty)) types) - if length vars > 0 - then return $ ForallC (map PlainTV vars) [] ctor - else return ctor - - -- demote a kind back to a type, accumulating any unbound parameters - kindToType :: Quasi q => Kind -> QWithAux [Name] q Type - kindToType (ForallT _ _ _) = fail "Explicit forall encountered in kind" - kindToType (AppT k1 k2) = do - t1 <- kindToType k1 - t2 <- kindToType k2 - return $ AppT t1 t2 - kindToType (SigT _ _) = fail "Sort signature encountered in kind" - kindToType (VarT n) = do - addElement n - return $ VarT n - kindToType (ConT n) = return $ ConT n - kindToType (PromotedT _) = fail "Promoted type used as a kind" - kindToType (TupleT n) = return $ TupleT n - kindToType (UnboxedTupleT _) = fail "Unboxed tuple kind encountered" - kindToType ArrowT = return ArrowT - kindToType ListT = return ListT - kindToType (PromotedTupleT _) = fail "Promoted tuple kind encountered" - kindToType PromotedNilT = fail "Promoted nil kind encountered" - kindToType PromotedConsT = fail "Promoted cons kind encountered" - kindToType StarT = return $ ConT repName - kindToType ConstraintT = - fail $ "Cannot make a representation of a type that has " ++ - "an argument of kind Constraint" - kindToType (LitT _) = fail "Literal encountered at the kind level" - -mkCustomEqInstances :: Quasi q => [Con] -> q [Dec] -mkCustomEqInstances ctors = do -#if __GLASGOW_HASKELL__ >= 707 - let ctorVar = error "Internal error: Equality instance inspected ctor var" - sCtors <- evalWithoutAux $ mapM (singCtor ctorVar) ctors - decideInst <- mkEqualityInstance StarT sCtors sDecideClassDesc - - a <- qNewName "a" - b <- qNewName "b" - let eqInst = InstanceD - [] - (AppT (ConT ''SEq) (kindParam StarT)) - [FunD '(%:==) - [Clause [VarP a, VarP b] - (NormalB $ - CaseE (foldExp (VarE '(%~)) [VarE a, VarE b]) - [ Match (ConP 'Proved [ConP 'Refl []]) - (NormalB $ ConE 'STrue) [] - , Match (ConP 'Disproved [WildP]) - (NormalB $ AppE (VarE 'unsafeCoerce) - (ConE 'SFalse)) [] - ]) []]] - return [decideInst, eqInst] -#else - mapM mkEqTypeInstance [(c1, c2) | c1 <- ctors, c2 <- ctors] -#endif diff --git a/Data/Singletons/Decide.hs b/Data/Singletons/Decide.hs deleted file mode 100644 --- a/Data/Singletons/Decide.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Decide --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines the class 'SDecide', allowing for decidable equality over singletons. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Decide ( - -- * The SDecide class - SDecide(..), - - -- * Supporting definitions - (:~:)(..), Void, Refuted, Decision(..) - ) where - -import Data.Singletons.Types -import Data.Singletons.Core -import Data.Singletons.Void - -#if __GLASGOW_HASKELL__ >= 707 -import Data.Type.Equality -#endif diff --git a/Data/Singletons/Either.hs b/Data/Singletons/Either.hs deleted file mode 100644 --- a/Data/Singletons/Either.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, GADTs, - DataKinds, PolyKinds, RankNTypes, UndecidableInstances, CPP #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Either --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'Either', --- including a singletons version of all the definitions in @Data.Either@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Either@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Either ( - -- * The 'Either' singleton - Sing(SLeft, SRight), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SLeft :: Sing a -> Sing (Left a) - -- > SRight :: Sing b -> Sing (Right b) - - SEither, - -- | 'SEither' is a kind-restricted synonym for 'Sing': - -- @type SEither (a :: Either x y) = Sing a@ - - -- * Singletons from @Data.Either@ - Either_, sEither_, - -- | The preceding two definitions are derived from the function 'either' in - -- @Data.Either@. The extra underscore is to avoid name clashes with the type - -- 'Either'. - - Lefts, sLefts, Rights, sRights, - PartitionEithers, sPartitionEithers, IsLeft, sIsLeft, IsRight, sIsRight - ) where - -import Data.Singletons.Core -import Data.Singletons.TH -import Data.Singletons.List - -$(singletonsOnly [d| - -- | Case analysis for the 'Either' type. - -- If the value is @'Left' a@, apply the first function to @a@; - -- if it is @'Right' b@, apply the second function to @b@. - either_ :: (a -> c) -> (b -> c) -> Either a b -> c - either_ f _ (Left x) = f x - either_ _ g (Right y) = g y - - -- | Extracts from a list of 'Either' all the 'Left' elements - -- All the 'Left' elements are extracted in order. - - lefts :: [Either a b] -> [a] - lefts [] = [] - lefts (Left x : xs) = x : lefts xs - lefts (Right _ : xs) = lefts xs - - -- | Extracts from a list of 'Either' all the 'Right' elements - -- All the 'Right' elements are extracted in order. - - rights :: [Either a b] -> [b] - rights [] = [] - rights (Left _ : xs) = rights xs - rights (Right x : xs) = x : rights xs - - -- | Partitions a list of 'Either' into two lists - -- All the 'Left' elements are extracted, in order, to the first - -- component of the output. Similarly the 'Right' elements are extracted - -- to the second component of the output. - - partitionEithers :: [Either a b] -> ([a],[b]) - partitionEithers es = partitionEithers_aux ([], []) es - - partitionEithers_aux :: ([a],[b]) -> [Either a b] -> ([a],[b]) - partitionEithers_aux (as,bs) [] = (reverse as,reverse bs) - partitionEithers_aux (as,bs) (Left a : es) = - partitionEithers_aux (a : as, bs) es - partitionEithers_aux (as,bs) (Right b : es) = - partitionEithers_aux (as, b : bs) es - - -- | Return `True` if the given value is a `Left`-value, `False` otherwise. - -- - -- /Since: 4.7.0.0/ - isLeft :: Either a b -> Bool - isLeft (Left _) = True - isLeft (Right _) = False - - -- | Return `True` if the given value is a `Right`-value, `False` otherwise. - -- - -- /Since: 4.7.0.0/ - isRight :: Either a b -> Bool - isRight (Left _) = False - isRight (Right _) = True - |]) diff --git a/Data/Singletons/Eq.hs b/Data/Singletons/Eq.hs deleted file mode 100644 --- a/Data/Singletons/Eq.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, - RankNTypes, FlexibleContexts, TemplateHaskell, - UndecidableInstances, GADTs, CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Eq --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines the SEq singleton version of the Eq type class. --- ------------------------------------------------------------------------------ - -module Data.Singletons.Eq ( - SEq(..), - type (==), (:==), (:/=) - ) where - -import Data.Singletons.Util -import Data.Singletons.Bool -import Data.Singletons.Singletons -import Data.Singletons.Core -import GHC.TypeLits ( Nat, Symbol ) -import Unsafe.Coerce -- for TypeLits instances - -#if __GLASGOW_HASKELL__ >= 707 - -import Data.Proxy -import Data.Type.Equality - --- | A re-export of the type-level @(==)@ that conforms to the singletons naming --- convention. -type a :== b = a == b - -#else -import Data.Singletons.Types -import Data.Singletons.Promote - -type family (a :: k) :== (b :: k) :: Bool -type a == b = a :== b - -#endif - -type a :/= b = Not (a :== b) - --- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is required --- that instances define a body for '(%:==)'. You may also supply a body for '(%:/=)'. -class (kparam ~ 'KProxy) => SEq (kparam :: KProxy k) where - -- | Boolean equality on singletons - (%:==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :== b) - - -- | Boolean disequality on singletons - (%:/=) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/= b) - a %:/= b = sNot (a %:== b) - -#if __GLASGOW_HASKELL__ < 707 -$(promoteEqInstances basicTypes) -- these instances are in Data.Type.Equality -#endif - -$(singEqInstancesOnly basicTypes) - --- need instances for TypeLits kinds -instance SEq ('KProxy :: KProxy Nat) where - (SNat a) %:== (SNat b) - | a == b = unsafeCoerce STrue - | otherwise = unsafeCoerce SFalse - -instance SEq ('KProxy :: KProxy Symbol) where - (SSym a) %:== (SSym b) - | a == b = unsafeCoerce STrue - | otherwise = unsafeCoerce SFalse diff --git a/Data/Singletons/List.hs b/Data/Singletons/List.hs deleted file mode 100644 --- a/Data/Singletons/List.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE CPP, TypeOperators, DataKinds, PolyKinds, TypeFamilies, - TemplateHaskell, GADTs, UndecidableInstances #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.List --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for '[]', --- including a singletons version of a few of the definitions in @Data.List@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.List@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.List ( - -- * The singleton for lists - Sing(SNil, SCons), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SNil :: Sing '[] - -- > SCons :: Sing (h :: k) -> Sing (t :: [k]) -> Sing (h ': t) - - SList, - -- | 'SList' is a kind-restricted synonym for 'Sing': @type SList (a :: [k]) = Sing a@ - - Head, Tail, sHead, sTail, - (:++), (%:++), - Reverse, sReverse - ) where - -import Data.Singletons.Core -import Data.Singletons -import Data.Singletons.Singletons - -$(singletonsOnly [d| - (++) :: [a] -> [a] -> [a] - [] ++ a = a - (h:t) ++ a = h:(t ++ a) - - head :: [a] -> a - head (a : _) = a - head [] = error "Data.Singletons.List.head: empty list" - - tail :: [a] -> [a] - tail (_ : t) = t - tail [] = error "Data.Singletons.List.tail: empty list" - - reverse :: [a] -> [a] - reverse list = reverse_aux [] list - - reverse_aux :: [a] -> [a] -> [a] - reverse_aux acc [] = acc - reverse_aux acc (h : t) = reverse_aux (h : acc) t - |]) - - diff --git a/Data/Singletons/Maybe.hs b/Data/Singletons/Maybe.hs deleted file mode 100644 --- a/Data/Singletons/Maybe.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, - DataKinds, PolyKinds, UndecidableInstances, GADTs, - RankNTypes, CPP #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Maybe --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for 'Maybe', --- including a singletons version of all the definitions in @Data.Maybe@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Maybe@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - - -module Data.Singletons.Maybe ( - -- The 'Maybe' singleton - - Sing(SNothing, SJust), - -- | Though Haddock doesn't show it, the 'Sing' instance above declares - -- constructors - -- - -- > SNothing :: Sing Nothing - -- > SJust :: Sing a -> Sing (Just a) - - SMaybe, - -- | 'SBool' is a kind-restricted synonym for 'Sing': @type SMaybe (a :: Maybe k) = Sing a@ - - -- * Singletons from @Data.Maybe@ - - Maybe_, sMaybe_, - -- | The preceding two definitions are derived from the function 'maybe' in - -- @Data.Maybe@. The extra underscore is to avoid name clashes with the type - -- 'Maybe'. - - IsJust, sIsJust, IsNothing, sIsNothing, - FromJust, sFromJust, FromMaybe, sFromMaybe, MaybeToList, sMaybeToList, - ListToMaybe, sListToMaybe, CatMaybes, sCatMaybes, MapMaybe, sMapMaybe - ) where - -import Data.Singletons.Core -import Data.Singletons -import Data.Singletons.TH -import Data.Singletons.List - -$(singletonsOnly [d| - -- | The 'maybe' function takes a default value, a function, and a 'Maybe' - -- value. If the 'Maybe' value is 'Nothing', the function returns the - -- default value. Otherwise, it applies the function to the value inside - -- the 'Just' and returns the result. - maybe_ :: b -> (a -> b) -> Maybe a -> b - maybe_ n _ Nothing = n - maybe_ _ f (Just x) = f x - - -- | The 'isJust' function returns 'True' iff its argument is of the - -- form @Just _@. - isJust :: Maybe a -> Bool - isJust Nothing = False - isJust (Just _) = True - - -- | The 'isNothing' function returns 'True' iff its argument is 'Nothing'. - isNothing :: Maybe a -> Bool - isNothing Nothing = True - isNothing (Just _) = False - - -- | The 'fromJust' function extracts the element out of a 'Just' and - -- throws an error if its argument is 'Nothing'. - fromJust :: Maybe a -> a - fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck - fromJust (Just x) = x - - -- | The 'fromMaybe' function takes a default value and and 'Maybe' - -- value. If the 'Maybe' is 'Nothing', it returns the default values; - -- otherwise, it returns the value contained in the 'Maybe'. - fromMaybe :: a -> Maybe a -> a - fromMaybe d Nothing = d - fromMaybe _ (Just v) = v - - -- | The 'maybeToList' function returns an empty list when given - -- 'Nothing' or a singleton list when not given 'Nothing'. - maybeToList :: Maybe a -> [a] - maybeToList Nothing = [] - maybeToList (Just x) = [x] - - -- | The 'listToMaybe' function returns 'Nothing' on an empty list - -- or @'Just' a@ where @a@ is the first element of the list. - listToMaybe :: [a] -> Maybe a - listToMaybe [] = Nothing - listToMaybe (a:_) = Just a - - -- | The 'catMaybes' function takes a list of 'Maybe's and returns - -- a list of all the 'Just' values. - catMaybes :: [Maybe a] -> [a] - catMaybes [] = [] - catMaybes (Just x : xs) = x : catMaybes xs - catMaybes (Nothing : xs) = catMaybes xs - - -- | The 'mapMaybe' function is a version of 'map' which can throw - -- out elements. In particular, the functional argument returns - -- something of type @'Maybe' b@. If this is 'Nothing', no element - -- is added on to the result list. If it just @'Just' b@, then @b@ is - -- included in the result list. - mapMaybe :: (a -> Maybe b) -> [a] -> [b] - mapMaybe _ [] = [] - mapMaybe f (x:xs) = maybeToList (f x) ++ (mapMaybe f xs) - |]) diff --git a/Data/Singletons/Prelude.hs b/Data/Singletons/Prelude.hs deleted file mode 100644 --- a/Data/Singletons/Prelude.hs +++ /dev/null @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Mimics the Haskell Prelude, but with singleton types. Includes the basic --- singleton definitions. Note: This is currently very incomplete! --- --- Because many of these definitions are produced by Template Haskell, it is --- not possible to create proper Haddock documentation. Also, please excuse --- the apparent repeated variable names. This is due to an interaction between --- Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Prelude ( - -- * Basic singleton definitions - module Data.Singletons, - - Sing(SFalse, STrue, SNil, SCons, SJust, SNothing, SLeft, SRight, SLT, SEQ, SGT, - STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7), - -- | Though Haddock doesn't show it, the 'Sing' instance above includes - -- the following instances - -- - -- > data instance Sing (a :: Bool) where - -- > SFalse :: Sing False - -- > STrue :: Sing True - -- > - -- > data instance Sing (a :: [k]) where - -- > SNil :: Sing '[] - -- > SCons :: Sing (h :: k) -> Sing (t :: [k]) -> Sing (h ': t) - -- > - -- > data instance Sing (a :: Maybe k) where - -- > SNothing :: Sing Nothing - -- > SJust :: Sing (a :: k) -> Sing (Just a) - -- > - -- > data instance Sing (a :: Either x y) where - -- > SLeft :: Sing (a :: x) -> Sing (Left a) - -- > SRight :: Sing (b :: y) -> Sing (Right b) - -- > - -- > data instance Sing (a :: Ordering) where - -- > SLT :: Sing LT - -- > SEQ :: Sing EQ - -- > SGT :: Sing GT - -- > - -- > data instance Sing (a :: ()) where - -- > STuple0 :: Sing '() - -- > - -- > data instance Sing (z :: (a, b)) where - -- > STuple2 :: Sing a -> Sing b -> Sing '(a, b) - -- > - -- > data instance Sing (z :: (a, b, c)) where - -- > STuple3 :: Sing a -> Sing b -> Sing c -> Sing '(a, b, c) - -- > - -- > data instance Sing (z :: (a, b, c, d)) where - -- > STuple4 :: Sing a -> Sing b -> Sing c -> Sing d -> Sing '(a, b, c, d) - -- > - -- > data instance Sing (z :: (a, b, c, d, e)) where - -- > STuple5 :: Sing a -> Sing b -> Sing c -> Sing d -> Sing e -> Sing '(a, b, c, d, e) - -- > - -- > data instance Sing (z :: (a, b, c, d, e, f)) where - -- > STuple6 :: Sing a -> Sing b -> Sing c -> Sing d -> Sing e -> Sing f - -- > -> Sing '(a, b, c, d, e, f) - -- > - -- > data instance Sing (z :: (a, b, c, d, e, f, g)) where - -- > STuple7 :: Sing a -> Sing b -> Sing c -> Sing d -> Sing e -> Sing f - -- > -> Sing g -> Sing '(a, b, c, d, e, f, g) - - -- * Singleton type synonyms - - -- | These synonyms are all kind-restricted synonyms of 'Sing'. - -- For example 'SBool' requires an argument of kind 'Bool'. - SBool, SList, SMaybe, SEither, - STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7, - - -- * Functions working with 'Bool' - If, sIf, Not, sNot, (:&&), (:||), (%:&&), (%:||), - - -- * Functions working with lists - Head, Tail, (:++), (%:++), - - -- * Singleton equality - module Data.Singletons.Eq, - - -- * Other datatypes - Maybe_, sMaybe_, - Either_, sEither_, - Fst, sFst, Snd, sSnd, Curry, sCurry, Uncurry, sUncurry - ) where - -import Data.Singletons -import Data.Singletons.Bool -import Data.Singletons.List -import Data.Singletons.Maybe -import Data.Singletons.Either -import Data.Singletons.Tuple -import Data.Singletons.Eq -import Data.Singletons.Core diff --git a/Data/Singletons/Promote.hs b/Data/Singletons/Promote.hs deleted file mode 100644 --- a/Data/Singletons/Promote.hs +++ /dev/null @@ -1,689 +0,0 @@ -{- Data/Singletons/Promote.hs - -(c) Richard Eisenberg 2013 -eir@cis.upenn.edu - -This file contains functions to promote term-level constructs to the -type level. It is an internal module to the singletons package. --} - -{-# LANGUAGE TemplateHaskell, CPP #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} - -module Data.Singletons.Promote where - -import Language.Haskell.TH hiding ( Q, cxt ) -import Language.Haskell.TH.Syntax ( falseName, trueName, Quasi(..) ) -import Data.Singletons.Util -import GHC.Exts (Any) -import GHC.TypeLits (Symbol) -import Prelude hiding (exp) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Control.Monad -import Data.List - -anyTypeName, boolName, andName, tyEqName, repName, ifName, - headName, tailName, symbolName :: Name -anyTypeName = ''Any -boolName = ''Bool -andName = mkName "&&" -#if __GLASGOW_HASKELL__ >= 707 -tyEqName = mkName "==" -#else -tyEqName = mkName ":==" -#endif -repName = mkName "Rep" -ifName = mkName "If" -headName = mkName "Head" -tailName = mkName "Tail" -symbolName = ''Symbol - -falseTy :: Type -falseTy = promoteDataCon falseName - -trueTy :: Type -trueTy = promoteDataCon trueName - -boolTy :: Type -boolTy = ConT boolName - -andTy :: Type -andTy = promoteVal andName - -ifTyFam :: Type -ifTyFam = ConT ifName - -headTyFam :: Type -headTyFam = ConT headName - -tailTyFam :: Type -tailTyFam = ConT tailName - -promoteInfo :: Quasi q => Info -> q [Dec] -promoteInfo (ClassI _dec _instances) = - fail "Promotion of class info not supported" -promoteInfo (ClassOpI _name _ty _className _fixity) = - fail "Promotion of class members info not supported" -promoteInfo (TyConI dec) = evalWithoutAux $ promoteDec Map.empty dec -promoteInfo (FamilyI _dec _instances) = - fail "Promotion of type family info not yet supported" -- KindFams -promoteInfo (PrimTyConI _name _numArgs _unlifted) = - fail "Promotion of primitive type constructors not supported" -promoteInfo (DataConI _name _ty _tyname _fixity) = - fail $ "Promotion of individual constructors not supported; " ++ - "promote the type instead" -promoteInfo (VarI _name _ty _mdec _fixity) = - fail "Promotion of value info not supported" -promoteInfo (TyVarI _name _ty) = - fail "Promotion of type variable info not supported" - -promoteDataCon :: Name -> Type -promoteDataCon name - | Just degree <- tupleNameDegree_maybe name - = PromotedTupleT degree - - | otherwise - = PromotedT name - -promoteValName :: Name -> Name -promoteValName n - | nameBase n == "undefined" = anyTypeName - | otherwise = upcase n - -promoteVal :: Name -> Type -promoteVal = ConT . promoteValName - -promoteType :: Quasi q => Type -> q Kind --- We don't need to worry about constraints: they are used to express --- static guarantees at runtime. But, because we don't need to do --- anything special to keep static guarantees at compile time, we don't --- need to promote them. -promoteType (ForallT _tvbs _ ty) = promoteType ty -- ForallKinds -promoteType (VarT name) = return $ VarT name -promoteType (ConT name) = return $ - case nameBase name of - "TypeRep" -> StarT - "String" -> ConT symbolName - x | x == nameBase repName -> StarT - | otherwise -> ConT name -promoteType (TupleT n) = return $ TupleT n -promoteType (UnboxedTupleT _n) = fail "Promotion of unboxed tuples not supported" -promoteType ArrowT = return ArrowT -promoteType ListT = return ListT -promoteType (AppT (AppT ArrowT (ForallT (_:_) _ _)) _) = - fail "Cannot promote types of rank above 1." -promoteType (AppT ty1 ty2) = do - k1 <- promoteType ty1 - k2 <- promoteType ty2 - return $ AppT k1 k2 -promoteType (SigT _ty _) = fail "Cannot promote type of kind other than *" -promoteType (LitT _) = fail "Cannot promote a type-level literal" -promoteType (PromotedT _) = fail "Cannot promote a promoted data constructor" -promoteType (PromotedTupleT _) = fail "Cannot promote tuples that are already promoted" -promoteType PromotedNilT = fail "Cannot promote a nil that is already promoted" -promoteType PromotedConsT = fail "Cannot promote a cons that is already promoted" -promoteType StarT = fail "* used as a type" -promoteType ConstraintT = fail "Constraint used as a type" - --- a table to keep track of variable->type mappings -type TypeTable = Map.Map Name Type - --- | Promote every declaration given to the type level, retaining the originals. -promote :: Quasi q => q [Dec] -> q [Dec] -promote qdec = do - decls <- qdec - (promDecls, _) <- promoteDecs decls - return $ decls ++ promDecls - --- | Promote each declaration, discarding the originals. -promoteOnly :: Quasi q => q [Dec] -> q [Dec] -promoteOnly qdec = do - decls <- qdec - (promDecls, _) <- promoteDecs decls - return promDecls - -checkForRep :: Quasi q => [Name] -> q () -checkForRep names = - when (any ((== nameBase repName) . nameBase) names) - (fail $ "A data type named <> is a special case.\n" ++ - "Promoting it will not work as expected.\n" ++ - "Please choose another name for your data type.") - -checkForRepInDecls :: Quasi q => [Dec] -> q () -checkForRepInDecls decls = - checkForRep (map extractNameFromDec decls) - where extractNameFromDec :: Dec -> Name - extractNameFromDec (DataD _ name _ _ _) = name - extractNameFromDec (NewtypeD _ name _ _ _) = name - extractNameFromDec (TySynD name _ _) = name - extractNameFromDec (FamilyD _ name _ _) = name - extractNameFromDec _ = mkName "NotRep" - --- Promote a list of declarations; returns the promoted declarations --- and a list of names of declarations without accompanying type signatures. --- (This list is needed by singletons to strike such definitions.) - --- Promoting declarations proceeds in two stages: --- 1) Promote everything except type signatures --- 2) Promote type signatures. This must be done in a second pass because --- a function type signature gets promoted to a type family declaration. --- Although function signatures do not differentiate between uniform parameters --- and non-uniform parameters, type family declarations do. We need --- to process a function's definition to get the count of non-uniform --- parameters before producing the type family declaration. --- At this point, any function written without a type signature is rejected --- and removed. -promoteDecs :: Quasi q => [Dec] -> q ([Dec], [Name]) -promoteDecs decls = do - checkForRepInDecls decls - let vartbl = Map.empty - (newDecls, table) <- evalForPair $ mapM (promoteDec vartbl) decls - (declss, namess) <- mapAndUnzipM (promoteDec' table) decls - let moreNewDecls = concat declss - names = concat namess - noTypeSigs = Set.toList $ Set.difference (Map.keysSet $ -#if __GLASGOW_HASKELL__ >= 707 - Map.filter ((>= 0) . fst) table) -#else - Map.filter (>= 0) table) -#endif - (Set.fromList names) - noTypeSigsPro = map promoteValName noTypeSigs - newDecls' = foldl (\bad_decls name -> - filter (not . (containsName name)) bad_decls) - (concat newDecls) (noTypeSigs ++ noTypeSigsPro) - mapM_ (\n -> qReportWarning $ "No type binding for " ++ (show (nameBase n)) ++ - "; removing all declarations including it") - noTypeSigs - return (newDecls' ++ moreNewDecls, noTypeSigs) - --- | Produce instances for '(:==)' (type-level equality) from the given types -promoteEqInstances :: Quasi q => [Name] -> q [Dec] -promoteEqInstances = concatMapM promoteEqInstance - --- | Produce an instance for '(:==)' (type-level equality) from the given type -promoteEqInstance :: Quasi q => Name -> q [Dec] -promoteEqInstance name = do - (_tvbs, cons) <- getDataD "I cannot make an instance of (:==:) for it." name -#if __GLASGOW_HASKELL__ >= 707 - vars <- replicateM (length _tvbs) (qNewName "k") - let tyvars = map VarT vars - kind = foldType (ConT name) tyvars - inst_decs <- mkEqTypeInstance kind cons - return inst_decs -#else - let pairs = [(c1, c2) | c1 <- cons, c2 <- cons] - mapM mkEqTypeInstance pairs -#endif - -#if __GLASGOW_HASKELL__ >= 707 - --- produce a closed type family helper and the instance --- for (:==) over the given list of ctors -mkEqTypeInstance :: Quasi q => Kind -> [Con] -> q [Dec] -mkEqTypeInstance kind cons = do - helperName <- newUniqueName "Equals" - aName <- qNewName "a" - bName <- qNewName "b" - true_branches <- mapM mk_branch cons - false_branch <- false_case - let closedFam = ClosedTypeFamilyD helperName - [ KindedTV aName kind - , KindedTV bName kind ] - (Just boolTy) - (true_branches ++ [false_branch]) - eqInst = TySynInstD tyEqName (TySynEqn [ SigT (VarT aName) kind - , SigT (VarT bName) kind ] - (foldType (ConT helperName) - [VarT aName, VarT bName])) - return [closedFam, eqInst] - - where mk_branch :: Quasi q => Con -> q TySynEqn - mk_branch con = do - let (name, numArgs) = extractNameArgs con - lnames <- replicateM numArgs (qNewName "a") - rnames <- replicateM numArgs (qNewName "b") - let lvars = map VarT lnames - rvars = map VarT rnames - ltype = foldType (PromotedT name) lvars - rtype = foldType (PromotedT name) rvars - results = zipWith (\l r -> foldType (ConT tyEqName) [l, r]) lvars rvars - result = tyAll results - return $ TySynEqn [ltype, rtype] result - - false_case :: Quasi q => q TySynEqn - false_case = do - lvar <- qNewName "a" - rvar <- qNewName "b" - return $ TySynEqn [SigT (VarT lvar) kind, SigT (VarT rvar) kind] falseTy - - tyAll :: [Type] -> Type -- "all" at the type level - tyAll [] = trueTy - tyAll [one] = one - tyAll (h:t) = foldType andTy [h, (tyAll t)] - -#else - --- produce the type instance for (:==) for the given pair of constructors -mkEqTypeInstance :: Quasi q => (Con, Con) -> q Dec -mkEqTypeInstance (c1, c2) = - if c1 == c2 - then do - let (name, numArgs) = extractNameArgs c1 - lnames <- replicateM numArgs (qNewName "a") - rnames <- replicateM numArgs (qNewName "b") - let lvars = map VarT lnames - rvars = map VarT rnames - return $ TySynInstD - tyEqName - [foldType (PromotedT name) lvars, - foldType (PromotedT name) rvars] - (tyAll (zipWith (\l r -> foldType (ConT tyEqName) [l, r]) - lvars rvars)) - else do - let (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM rNumArgs (qNewName "b") - return $ TySynInstD - tyEqName - [foldType (PromotedT lname) (map VarT lnames), - foldType (PromotedT rname) (map VarT rnames)] - falseTy - where tyAll :: [Type] -> Type -- "all" at the type level - tyAll [] = trueTy - tyAll [one] = one - tyAll (h:t) = foldType andTy [h, (tyAll t)] - -#endif - --- keeps track of the number of non-uniform parameters to promoted values --- and all of the instance equations for those values -#if __GLASGOW_HASKELL__ >= 707 -type PromoteTable = Map.Map Name (Int, [TySynEqn]) -#else -type PromoteTable = Map.Map Name Int -#endif -type PromoteQ q = QWithAux PromoteTable q - --- used when a type is declared as a type synonym, not a type family --- no need to declare "type family ..." for these -typeSynonymFlag :: Int -typeSynonymFlag = -1 - -promoteDec :: Quasi q => TypeTable -> Dec -> PromoteQ q [Dec] -promoteDec vars (FunD name clauses) = do - let proName = promoteValName name - vars' = Map.insert name (promoteVal name) vars - numArgs = getNumPats (head clauses) -- count the parameters - -- Haskell requires all clauses to have the same number of parameters - (eqns, instDecls) <- evalForPair $ - mapM (promoteClause vars' proName) clauses -#if __GLASGOW_HASKELL__ >= 707 - addBinding name (numArgs, eqns) -- remember the number of parameters and the eqns - return instDecls -#else - addBinding name numArgs -- remember the number of parameters - return $ eqns ++ instDecls -#endif - where getNumPats :: Clause -> Int - getNumPats (Clause pats _ _) = length pats -promoteDec vars (ValD pat body decs) = do - -- see also the comment for promoteTopLevelPat - when (length decs > 0) - (fail $ "Promotion of global variable with <> clause " ++ - "not yet supported") - (rhs, decls) <- evalForPair $ promoteBody vars body - (lhss, decls') <- evalForPair $ promoteTopLevelPat pat - if any (flip containsName rhs) (map lhsName lhss) - then -- definition is recursive. This means an infinite value. - fail "Promotion of infinite terms not yet supported" - else do -- definition is not recursive; just use "type" decls -#if __GLASGOW_HASKELL__ >= 707 - mapM_ (flip addBinding (typeSynonymFlag, [])) (map lhsRawName lhss) -#else - mapM_ (flip addBinding typeSynonymFlag) (map lhsRawName lhss) -#endif - return $ (map (\(LHS _ nm hole) -> TySynD nm [] (hole rhs)) lhss) ++ - decls ++ decls' -promoteDec vars (DataD cxt name tvbs ctors derivings) = - promoteDataD vars cxt name tvbs ctors derivings -promoteDec vars (NewtypeD cxt name tvbs ctor derivings) = - promoteDataD vars cxt name tvbs [ctor] derivings -promoteDec _vars (TySynD _name _tvbs _ty) = - fail "Promotion of type synonym declaration not yet supported" -promoteDec _vars (ClassD _cxt _name _tvbs _fundeps _decs) = - fail "Promotion of class declaration not yet supported" -promoteDec _vars (InstanceD _cxt _ty _decs) = - fail "Promotion of instance declaration not yet supported" -promoteDec _vars (SigD _name _ty) = return [] -- handle in promoteDec' -promoteDec _vars (ForeignD _fgn) = - fail "Promotion of foreign function declaration not yet supported" -promoteDec _vars (InfixD fixity name) - | isUpcase name = return [] -- automatic: promoting a type or data ctor - | otherwise = return [InfixD fixity (promoteValName name)] -- value -promoteDec _vars (PragmaD _prag) = - fail "Promotion of pragmas not yet supported" -promoteDec _vars (FamilyD _flavour _name _tvbs _mkind) = - fail "Promotion of type and data families not yet supported" -promoteDec _vars (DataInstD _cxt _name _tys _ctors _derivings) = - fail "Promotion of data instances not yet supported" -promoteDec _vars (NewtypeInstD _cxt _name _tys _ctors _derivings) = - fail "Promotion of newtype instances not yet supported" -#if __GLASGOW_HASKELL__ >= 707 -promoteDec _vars (RoleAnnotD _name _roles) = - return [] -- silently ignore role annotations, as they're harmless here -promoteDec _vars (ClosedTypeFamilyD _name _tvs _mkind _eqns) = - fail "Promotion of closed type families not yet supported" -promoteDec _vars (TySynInstD _name _eqn) = -#else -promoteDec _vars (TySynInstD _name _lhs _rhs) = -#endif - fail "Promotion of type synonym instances not yet supported" - --- only need to check if the datatype derives Eq. The rest is automatic. -promoteDataD :: Quasi q => TypeTable -> Cxt -> Name -> [TyVarBndr] -> [Con] -> - [Name] -> PromoteQ q [Dec] -promoteDataD _vars _cxt _name _tvbs ctors derivings = - if any (\n -> (nameBase n) == "Eq") derivings - then do -#if __GLASGOW_HASKELL__ >= 707 - kvs <- replicateM (length _tvbs) (qNewName "k") - inst_decs <- mkEqTypeInstance (foldType (ConT _name) (map VarT kvs)) ctors - return inst_decs -#else - let pairs = [ (c1, c2) | c1 <- ctors, c2 <- ctors ] - mapM mkEqTypeInstance pairs -#endif - else return [] -- the actual promotion is automatic - --- second pass through declarations to deal with type signatures --- returns the new declarations and the list of names that have been --- processed -promoteDec' :: Quasi q => PromoteTable -> Dec -> q ([Dec], [Name]) -promoteDec' tab (SigD name ty) = case Map.lookup name tab of - Nothing -> fail $ "Type declaration is missing its binding: " ++ (show name) -#if __GLASGOW_HASKELL__ >= 707 - Just (numArgs, eqns) -> -#else - Just numArgs -> -#endif - -- if there are no args, then use a type synonym, not a type family - -- in the type synonym case, we ignore the type signature - if numArgs == typeSynonymFlag then return $ ([], [name]) else do - k <- promoteType ty - let ks = unravel k - (argKs, resultKs) = splitAt numArgs ks -- divide by uniformity - resultK <- ravel resultKs -- rebuild the arrow kind - tyvarNames <- mapM qNewName (replicate (length argKs) "a") -#if __GLASGOW_HASKELL__ >= 707 - return ([ClosedTypeFamilyD (promoteValName name) - (zipWith KindedTV tyvarNames argKs) - (Just resultK) - eqns], [name]) -#else - return ([FamilyD TypeFam - (promoteValName name) - (zipWith KindedTV tyvarNames argKs) - (Just resultK)], [name]) -#endif - where unravel :: Kind -> [Kind] -- get argument kinds from an arrow kind - unravel (AppT (AppT ArrowT k1) k2) = - let ks = unravel k2 in k1 : ks - unravel k = [k] - - ravel :: Quasi q => [Kind] -> q Kind - ravel [] = fail "Internal error: raveling nil" - ravel [k] = return k - ravel (h:t) = do - k <- ravel t - return $ (AppT (AppT ArrowT h) k) -promoteDec' _ _ = return ([], []) - -#if __GLASGOW_HASKELL__ >= 707 -promoteClause :: Quasi q => TypeTable -> Name -> Clause -> QWithDecs q TySynEqn -#else -promoteClause :: Quasi q => TypeTable -> Name -> Clause -> QWithDecs q Dec -#endif -promoteClause vars _name (Clause pats body []) = do - -- promoting the patterns creates variable bindings. These are passed - -- to the function promoted the RHS - (types, vartbl) <- evalForPair $ mapM promotePat pats - let vars' = Map.union vars vartbl - ty <- promoteBody vars' body -#if __GLASGOW_HASKELL__ >= 707 - return $ TySynEqn types ty -#else - return $ TySynInstD _name types ty -#endif -promoteClause _ _ (Clause _ _ (_:_)) = - fail "A <> clause in a function definition is not yet supported" - --- the LHS of a top-level expression is a name and "type with hole" --- the hole is filled in by the RHS -data TopLevelLHS = LHS { lhsRawName :: Name -- the unpromoted name - , lhsName :: Name - , lhsHole :: Type -> Type - } - --- Treatment of top-level patterns is different from other patterns --- because type families have type patterns as their LHS. However, --- it is not possible to use type patterns at the top level, so we --- have to use other techniques. -promoteTopLevelPat :: Quasi q => Pat -> QWithDecs q [TopLevelLHS] -promoteTopLevelPat (LitP _) = fail "Cannot declare a global literal." -promoteTopLevelPat (VarP name) = return [LHS name (promoteValName name) id] -promoteTopLevelPat (TupP pats) = case length pats of - 0 -> return [] -- unit as LHS of pattern... ignore - 1 -> fail "1-tuple encountered during top-level pattern promotion" - n -> promoteTopLevelPat (ConP (tupleDataName n) pats) -promoteTopLevelPat (UnboxedTupP _) = - fail "Promotion of unboxed tuples not supported" - --- to promote a constructor pattern, we need to create extraction type --- families to pull out the individual arguments of the constructor -promoteTopLevelPat (ConP name pats) = do - ctorInfo <- reifyWithWarning name - (ctorType, argTypes) <- extractTypes ctorInfo - when (length argTypes /= length pats) $ - fail $ "Inconsistent data constructor pattern: " ++ (show name) ++ " " ++ - (show pats) - kind <- promoteType ctorType - argKinds <- mapM promoteType argTypes - extractorNames <- replicateM (length pats) (newUniqueName "Extract") - - varName <- qNewName "a" - zipWithM_ (\nm arg -> addElement $ FamilyD TypeFam - nm - [KindedTV varName kind] - (Just arg)) - extractorNames argKinds - componentNames <- replicateM (length pats) (qNewName "a") - zipWithM_ (\extractorName componentName -> - addElement $ mkTyFamInst extractorName - [foldType (promoteDataCon name) - (map VarT componentNames)] - (VarT componentName)) - extractorNames componentNames - - -- now we have the extractor families. Use the appropriate families - -- in the "holes" - promotedPats <- mapM promoteTopLevelPat pats - return $ concat $ - zipWith (\lhslist extractor -> - map (\(LHS raw nm hole) -> LHS raw nm - (hole . (AppT (ConT extractor)))) - lhslist) - promotedPats extractorNames - where extractTypes :: Quasi q => Info -> q (Type, [Type]) - extractTypes (DataConI datacon _dataconTy tyname _fixity) = do - tyinfo <- reifyWithWarning tyname - extractTypesHelper datacon tyinfo - extractTypes _ = fail "Internal error: unexpected Info in extractTypes" - - extractTypesHelper :: Quasi q => Name -> Info -> q (Type, [Type]) - extractTypesHelper datacon - (TyConI (DataD _cxt tyname tvbs cons _derivs)) = - let mcon = find ((== datacon) . fst . extractNameArgs) cons in - case mcon of - Nothing -> fail $ "Internal error reifying " ++ (show datacon) - Just con -> return (foldType (ConT tyname) - (map (VarT . extractTvbName) tvbs), - extractConArgs con) - extractTypesHelper datacon - (TyConI (NewtypeD cxt tyname tvbs con derivs)) = - extractTypesHelper datacon (TyConI (DataD cxt tyname tvbs [con] derivs)) - extractTypesHelper datacon _ = - fail $ "Cannot promote data constructor " ++ (show datacon) - - extractConArgs :: Con -> [Type] - extractConArgs = ctor1Case (\_ tys -> tys) -promoteTopLevelPat (InfixP l name r) = promoteTopLevelPat (ConP name [l, r]) -promoteTopLevelPat (UInfixP _ _ _) = - fail "Unresolved infix constructors not supported" -promoteTopLevelPat (ParensP _) = - fail "Unresolved infix constructors not supported" -promoteTopLevelPat (TildeP pat) = do - qReportWarning "Lazy pattern converted into regular pattern in promotion" - promoteTopLevelPat pat -promoteTopLevelPat (BangP pat) = do - qReportWarning "Strict pattern converted into regular pattern in promotion" - promoteTopLevelPat pat -promoteTopLevelPat (AsP _name _pat) = - fail "Promotion of aliased patterns at top level not yet supported" -promoteTopLevelPat WildP = return [] -promoteTopLevelPat (RecP _ _) = - fail "Promotion of record patterns at top level not yet supported" - --- must do a similar trick as what is in the ConP case, but this is easier --- because Lib defined Head and Tail -promoteTopLevelPat (ListP pats) = do - promotedPats <- mapM promoteTopLevelPat pats - return $ concat $ snd $ - mapAccumL (\extractFn lhss -> - ((AppT tailTyFam) . extractFn, - map (\(LHS raw nm hole) -> - LHS raw nm (hole . (AppT headTyFam) . extractFn)) lhss)) - id promotedPats -promoteTopLevelPat (SigP pat _) = do - qReportWarning $ "Promotion of explicit type annotation in pattern " ++ - "not yet supported." - promoteTopLevelPat pat -promoteTopLevelPat (ViewP _ _) = - fail "Promotion of view patterns not yet supported" - -type TypesQ q = QWithAux TypeTable q - --- promotes a term pattern into a type pattern, accumulating variable --- binding in the auxiliary TypeTable -promotePat :: Quasi q => Pat -> TypesQ q Type -promotePat (LitP lit) = promoteLit lit -promotePat (VarP name) = do - tyVar <- qNewName (nameBase name) - addBinding name (VarT tyVar) - return $ VarT tyVar -promotePat (TupP pats) = do - types <- mapM promotePat pats - let baseTup = PromotedTupleT (length types) - tup = foldType baseTup types - return tup -promotePat (UnboxedTupP _) = fail "Unboxed tuples not supported" -promotePat (ConP name pats) = do - types <- mapM promotePat pats - let tyCon = foldType (promoteDataCon name) types - return tyCon -promotePat (InfixP pat1 name pat2) = promotePat (ConP name [pat1, pat2]) -promotePat (UInfixP _ _ _) = fail "Unresolved infix constructions not supported" -promotePat (ParensP _) = fail "Unresolved infix constructions not supported" -promotePat (TildeP pat) = do - qReportWarning "Lazy pattern converted into regular pattern in promotion" - promotePat pat -promotePat (BangP pat) = do - qReportWarning "Strict pattern converted into regular pattern in promotion" - promotePat pat -promotePat (AsP name pat) = do - ty <- promotePat pat - addBinding name ty - return ty -promotePat WildP = do - name <- qNewName "z" - return $ VarT name -promotePat (RecP _ _) = fail "Promotion of record patterns not yet supported" -promotePat (ListP pats) = do - types <- mapM promotePat pats - return $ foldr (\h t -> AppT (AppT PromotedConsT h) t) PromotedNilT types -promotePat (SigP pat _) = do - qReportWarning $ "Promotion of explicit type annotation in pattern " ++ - "not yet supported" - promotePat pat -promotePat (ViewP _ _) = fail "View patterns not yet supported" - --- promoting a body may produce auxiliary declarations. Accumulate these. -type QWithDecs q = QWithAux [Dec] q - -promoteBody :: Quasi q => TypeTable -> Body -> QWithDecs q Type -promoteBody vars (NormalB exp) = promoteExp vars exp -promoteBody _vars (GuardedB _) = - fail "Promoting guards in patterns not yet supported" - -promoteExp :: Quasi q => TypeTable -> Exp -> QWithDecs q Type -promoteExp vars (VarE name) = case Map.lookup name vars of - Just ty -> return ty - Nothing -> return $ promoteVal name -promoteExp _vars (ConE name) = return $ promoteDataCon name -promoteExp _vars (LitE lit) = promoteLit lit -promoteExp vars (AppE exp1 exp2) = do - ty1 <- promoteExp vars exp1 - ty2 <- promoteExp vars exp2 - return $ AppT ty1 ty2 -promoteExp vars (InfixE mexp1 exp mexp2) = - case (mexp1, mexp2) of - (Nothing, Nothing) -> promoteExp vars exp - (Just exp1, Nothing) -> promoteExp vars (AppE exp exp1) - (Nothing, Just _exp2) -> - fail "Promotion of right-only sections not yet supported" - (Just exp1, Just exp2) -> promoteExp vars (AppE (AppE exp exp1) exp2) -promoteExp _vars (UInfixE _ _ _) = - fail "Promotion of unresolved infix operators not supported" -promoteExp _vars (ParensE _) = fail "Promotion of unresolved parens not supported" -promoteExp _vars (LamE _pats _exp) = - fail "Promotion of lambda expressions not yet supported" -promoteExp _vars (LamCaseE _alts) = - fail "Promotion of lambda-case expressions not yet supported" -promoteExp vars (TupE exps) = do - tys <- mapM (promoteExp vars) exps - let tuple = PromotedTupleT (length tys) - tup = foldType tuple tys - return tup -promoteExp _vars (UnboxedTupE _) = fail "Promotion of unboxed tuples not supported" -promoteExp vars (CondE bexp texp fexp) = do - tys <- mapM (promoteExp vars) [bexp, texp, fexp] - return $ foldType ifTyFam tys -promoteExp _vars (MultiIfE _alts) = - fail "Promotion of multi-way if not yet supported" -promoteExp _vars (LetE _decs _exp) = - fail "Promotion of let statements not yet supported" -promoteExp _vars (CaseE _exp _matches) = - fail "Promotion of case statements not yet supported" -promoteExp _vars (DoE _stmts) = fail "Promotion of do statements not supported" -promoteExp _vars (CompE _stmts) = - fail "Promotion of list comprehensions not yet supported" -promoteExp _vars (ArithSeqE _) = fail "Promotion of ranges not supported" -promoteExp vars (ListE exps) = do - tys <- mapM (promoteExp vars) exps - return $ foldr (\ty lst -> AppT (AppT PromotedConsT ty) lst) PromotedNilT tys -promoteExp _vars (SigE _exp _ty) = - fail "Promotion of explicit type annotations not yet supported" -promoteExp _vars (RecConE _name _fields) = - fail "Promotion of record construction not yet supported" -promoteExp _vars (RecUpdE _exp _fields) = - fail "Promotion of record updates not yet supported" - -promoteLit :: Monad m => Lit -> m Type -promoteLit (IntegerL n) - | n >= 0 = return $ LitT (NumTyLit n) - | otherwise = fail ("Promoting negative integers not supported: " ++ (show n)) -promoteLit (StringL str) = return $ LitT (StrTyLit str) -promoteLit lit = - fail ("Only string and natural number literals can be promoted: " ++ show lit) diff --git a/Data/Singletons/Singletons.hs b/Data/Singletons/Singletons.hs deleted file mode 100644 --- a/Data/Singletons/Singletons.hs +++ /dev/null @@ -1,740 +0,0 @@ -{- Data/Singletons/Singletons.hs - -(c) Richard Eisenberg 2013 -eir@cis.upenn.edu - -This file contains functions to refine constructs to work with singleton -types. It is an internal module to the singletons package. --} -{-# LANGUAGE TemplateHaskell, CPP, TupleSections #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} - -module Data.Singletons.Singletons where - -import Prelude hiding ( exp ) -import Language.Haskell.TH hiding ( cxt ) -import Language.Haskell.TH.Syntax (falseName, trueName, Quasi(..)) -import Data.Singletons.Util -import Data.Singletons.Promote -import qualified Data.Map as Map -import Control.Monad -import Control.Applicative -import Data.Singletons.Types - -#if __GLASGOW_HASKELL__ >= 707 -import Data.Proxy -import Data.Type.Equality -#endif - --- map to track bound variables -type ExpTable = Map.Map Name Exp - --- translating a type gives a type with a hole in it, --- represented here as a function -type TypeFn = Type -> Type - --- a list of argument types extracted from a type application -type TypeContext = [Type] - -singFamilyName, singIName, singMethName, demoteRepName, singKindClassName, - sEqClassName, sEqMethName, sconsName, snilName, sIfName, undefinedName, - kProxyDataName, kProxyTypeName, someSingTypeName, someSingDataName, - nilName, consName, sListName, eqName, sDecideClassName, sDecideMethName, - provedName, disprovedName, reflName, toSingName, fromSingName, listName :: Name -singFamilyName = mkName "Sing" -singIName = mkName "SingI" -singMethName = mkName "sing" -toSingName = mkName "toSing" -fromSingName = mkName "fromSing" -demoteRepName = mkName "DemoteRep" -singKindClassName = mkName "SingKind" -sEqClassName = mkName "SEq" -sEqMethName = mkName "%:==" -sIfName = mkName "sIf" -undefinedName = 'undefined -sconsName = mkName "SCons" -snilName = mkName "SNil" -kProxyDataName = 'KProxy -kProxyTypeName = ''KProxy -someSingTypeName = mkName "SomeSing" -someSingDataName = mkName "SomeSing" -nilName = '[] -consName = '(:) -listName = ''[] -sListName = mkName "SList" -eqName = ''Eq -sDecideClassName = mkName "SDecide" -sDecideMethName = mkName "%~" -provedName = 'Proved -disprovedName = 'Disproved -reflName = 'Refl - -mkTupleName :: Int -> Name -mkTupleName n = mkName $ "STuple" ++ (show n) - -singFamily :: Type -singFamily = ConT singFamilyName - -singKindConstraint :: Kind -> Pred -singKindConstraint k = ClassP singKindClassName [kindParam k] - -demote :: Type -demote = ConT demoteRepName - -singDataConName :: Name -> Name -singDataConName nm - | nm == nilName = snilName - | nm == consName = sconsName - | Just degree <- tupleNameDegree_maybe nm = mkTupleName degree - | otherwise = prefixUCName "S" ":%" nm - -singTyConName :: Name -> Name -singTyConName name - | name == listName = sListName - | Just degree <- tupleNameDegree_maybe name = mkTupleName degree - | otherwise = prefixUCName "S" ":%" name - -singClassName :: Name -> Name -singClassName = singTyConName - -singDataCon :: Name -> Exp -singDataCon = ConE . singDataConName - -singValName :: Name -> Name -singValName n - | nameBase n == "undefined" = undefinedName - | otherwise = (prefixLCName "s" "%") $ upcase n - -singVal :: Name -> Exp -singVal = VarE . singValName - -kindParam :: Kind -> Type -kindParam k = SigT (ConT kProxyDataName) (AppT (ConT kProxyTypeName) k) - --- | Generate singleton definitions from a type that is already defined. --- For example, the singletons package itself uses --- --- > $(genSingletons [''Bool, ''Maybe, ''Either, ''[]]) --- --- to generate singletons for Prelude types. -genSingletons :: Quasi q => [Name] -> q [Dec] -genSingletons names = do - checkForRep names - concatMapM (singInfo <=< reifyWithWarning) names - -singInfo :: Quasi q => Info -> q [Dec] -singInfo (ClassI _dec _instances) = - fail "Singling of class info not supported" -singInfo (ClassOpI _name _ty _className _fixity) = - fail "Singling of class members info not supported" -singInfo (TyConI dec) = singDec dec -singInfo (FamilyI _dec _instances) = - fail "Singling of type family info not yet supported" -- KindFams -singInfo (PrimTyConI _name _numArgs _unlifted) = - fail "Singling of primitive type constructors not supported" -singInfo (DataConI _name _ty _tyname _fixity) = - fail $ "Singling of individual constructors not supported; " ++ - "single the type instead" -singInfo (VarI _name _ty _mdec _fixity) = - fail "Singling of value info not supported" -singInfo (TyVarI _name _ty) = - fail "Singling of type variable info not supported" - --- refine a constructor. the first parameter is the type variable that --- the singleton GADT is parameterized by --- runs in the QWithDecs monad because auxiliary declarations are produced -singCtor :: Quasi q => Type -> Con -> QWithDecs q Con -singCtor a = ctorCases - -- monomorphic case - (\name types -> do - let sName = singDataConName name - sCon = singDataCon name - pCon = promoteDataCon name - indexNames <- replicateM (length types) (qNewName "n") - let indices = map VarT indexNames - kinds <- mapM promoteType types - args <- buildArgTypes types indices - let tvbs = zipWith KindedTV indexNames kinds - kindedIndices = zipWith SigT indices kinds - - -- SingI instance - addElement $ InstanceD (map (ClassP singIName . listify) indices) - (AppT (ConT singIName) - (foldType pCon kindedIndices)) - [ValD (VarP singMethName) - (NormalB $ foldExp sCon (replicate (length types) - (VarE singMethName))) - []] - - return $ ForallC tvbs - [EqualP a (foldType pCon indices)] - (NormalC sName $ map (NotStrict,) args)) - - -- polymorphic case - (\_tvbs cxt ctor -> case cxt of - _:_ -> fail "Singling of constrained constructors not yet supported" - [] -> singCtor a ctor) -- polymorphic constructors are handled just - -- like monomorphic ones -- the polymorphism in - -- the kind is automatic - where buildArgTypes :: Quasi q => [Type] -> [Type] -> q [Type] - buildArgTypes types indices = do - typeFns <- mapM singType types - return $ zipWith id typeFns indices - --- | Make promoted and singleton versions of all declarations given, retaining --- the original declarations. --- See for --- further explanation. -singletons :: Quasi q => q [Dec] -> q [Dec] -singletons = (>>= singDecs True) - --- | Make promoted and singleton versions of all declarations given, discarding --- the original declarations. -singletonsOnly :: Quasi q => q [Dec] -> q [Dec] -singletonsOnly = (>>= singDecs False) - --- first parameter says whether or not to include original decls -singDecs :: Quasi q => Bool -> [Dec] -> q [Dec] -singDecs originals decls = do - (promDecls, badNames) <- promoteDecs decls - -- need to remove the bad names returned from promoteDecs - newDecls <- mapM singDec - (filter (\dec -> - not $ or (map (\f -> f dec) - (map containsName badNames))) decls) - return $ (if originals then (decls ++) else id) $ promDecls ++ (concat newDecls) - -singDec :: Quasi q => Dec -> q [Dec] -singDec (FunD name clauses) = do - let sName = singValName name - vars = Map.singleton name (VarE sName) - listify <$> FunD sName <$> (mapM (singClause vars) clauses) -singDec (ValD _ (GuardedB _) _) = - fail "Singling of definitions of values with a pattern guard not yet supported" -singDec (ValD _ _ (_:_)) = - fail "Singling of definitions of values with a <> clause not yet supported" -singDec (ValD pat (NormalB exp) []) = do - (sPat, vartbl) <- evalForPair $ singPat TopLevel pat - sExp <- singExp vartbl exp - return [ValD sPat (NormalB sExp) []] -singDec (DataD (_:_) _ _ _ _) = - fail "Singling of constrained datatypes not supported" -singDec (DataD cxt name tvbs ctors derivings) = - singDataD False cxt name tvbs ctors derivings -singDec (NewtypeD cxt name tvbs ctor derivings) = - singDataD False cxt name tvbs [ctor] derivings -singDec (TySynD _name _tvbs _ty) = - fail "Singling of type synonyms not yet supported" -singDec (ClassD _cxt _name _tvbs _fundeps _decs) = - fail "Singling of class declaration not yet supported" -singDec (InstanceD _cxt _ty _decs) = - fail "Singling of class instance not yet supported" -singDec (SigD name ty) = do - tyTrans <- singType ty - return [SigD (singValName name) (tyTrans (promoteVal name))] -singDec (ForeignD fgn) = - let name = extractName fgn in do - qReportWarning $ "Singling of foreign functions not supported -- " ++ - (show name) ++ " ignored" - return [] - where extractName :: Foreign -> Name - extractName (ImportF _ _ _ n _) = n - extractName (ExportF _ _ n _) = n -singDec (InfixD fixity name) - | isUpcase name = return [InfixD fixity (singDataConName name)] - | otherwise = return [InfixD fixity (singValName name)] -singDec (PragmaD _prag) = do - qReportWarning "Singling of pragmas not supported" - return [] -singDec (FamilyD _flavour _name _tvbs _mkind) = - fail "Singling of type and data families not yet supported" -singDec (DataInstD _cxt _name _tys _ctors _derivings) = - fail "Singling of data instances not yet supported" -singDec (NewtypeInstD _cxt _name _tys _ctor _derivings) = - fail "Singling of newtype instances not yet supported" -#if __GLASGOW_HASKELL__ >= 707 -singDec (RoleAnnotD _name _roles) = - return [] -- silently ignore role annotations, as they're harmless -singDec (ClosedTypeFamilyD _name _tvs _mkind _eqns) = - fail "Singling of closed type families not yet supported" -singDec (TySynInstD _name _eqns) = -#else -singDec (TySynInstD _name _lhs _rhs) = -#endif - fail "Singling of type family instances not yet supported" - --- | Create instances of 'SEq' and type-level '(:==)' for each type in the list -singEqInstances :: Quasi q => [Name] -> q [Dec] -singEqInstances = concatMapM singEqInstance - --- | Create instance of 'SEq' and type-level '(:==)' for the given type -singEqInstance :: Quasi q => Name -> q [Dec] -singEqInstance name = do - promotion <- promoteEqInstance name - dec <- singEqualityInstance sEqClassDesc name - return $ dec : promotion - --- | Create instances of 'SEq' (only -- no instance for '(:==)', which 'SEq' generally --- relies on) for each type in the list -singEqInstancesOnly :: Quasi q => [Name] -> q [Dec] -singEqInstancesOnly = concatMapM singEqInstanceOnly - --- | Create instances of 'SEq' (only -- no instance for '(:==)', which 'SEq' generally --- relies on) for the given type -singEqInstanceOnly :: Quasi q => Name -> q [Dec] -singEqInstanceOnly name = listify <$> singEqualityInstance sEqClassDesc name - --- | Create instances of 'SDecide' for each type in the list -singDecideInstances :: Quasi q => [Name] -> q [Dec] -singDecideInstances = concatMapM singDecideInstance - --- | Create instance of SDecide for the given type -singDecideInstance :: Quasi q => Name -> q [Dec] -singDecideInstance name = listify <$> singEqualityInstance sDecideClassDesc name - --- generalized function for creating equality instances -singEqualityInstance :: Quasi q => EqualityClassDesc q -> Name -> q Dec -singEqualityInstance desc@(_, className, _) name = do - (tvbs, cons) <- getDataD ("I cannot make an instance of " ++ - show className ++ " for it.") name - let tyvars = map (VarT . extractTvbName) tvbs - kind = foldType (ConT name) tyvars - aName <- qNewName "a" - let aVar = VarT aName - scons <- mapM (evalWithoutAux . singCtor aVar) cons - mkEqualityInstance kind scons desc - --- making the SEq instance and the SDecide instance are rather similar, --- so we generalize -type EqualityClassDesc q = ((Con, Con) -> q Clause, Name, Name) -sEqClassDesc, sDecideClassDesc :: Quasi q => EqualityClassDesc q -sEqClassDesc = (mkEqMethClause, sEqClassName, sEqMethName) -sDecideClassDesc = (mkDecideMethClause, sDecideClassName, sDecideMethName) - --- pass the *singleton* constructors, not the originals -mkEqualityInstance :: Quasi q => Kind -> [Con] - -> EqualityClassDesc q -> q Dec -mkEqualityInstance k ctors (mkMeth, className, methName) = do - let ctorPairs = [ (c1, c2) | c1 <- ctors, c2 <- ctors ] - methClauses <- if null ctors - then mkEmptyMethClauses - else mapM mkMeth ctorPairs - return $ InstanceD (map (\kvar -> ClassP className [kindParam kvar]) - (getKindVars k)) - (AppT (ConT className) - (kindParam k)) - [FunD methName methClauses] - where getKindVars :: Kind -> [Kind] - getKindVars (AppT l r) = getKindVars l ++ getKindVars r - getKindVars (VarT x) = [VarT x] - getKindVars (ConT _) = [] - getKindVars StarT = [] - getKindVars other = - error ("getKindVars sees an unusual kind: " ++ show other) - - mkEmptyMethClauses :: Quasi q => q [Clause] - mkEmptyMethClauses = do - a <- qNewName "a" - return [Clause [VarP a, WildP] (NormalB (CaseE (VarE a) emptyMatches)) []] - -mkEqMethClause :: Quasi q => (Con, Con) -> q Clause -mkEqMethClause (c1, c2) - | lname == rname = do - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM lNumArgs (qNewName "b") - let lpats = map VarP lnames - rpats = map VarP rnames - lvars = map VarE lnames - rvars = map VarE rnames - return $ Clause - [ConP lname lpats, ConP rname rpats] - (NormalB $ - allExp (zipWith (\l r -> foldExp (VarE sEqMethName) [l, r]) - lvars rvars)) - [] - | otherwise = - return $ Clause - [ConP lname (replicate lNumArgs WildP), - ConP rname (replicate rNumArgs WildP)] - (NormalB (singDataCon falseName)) - [] - where allExp :: [Exp] -> Exp - allExp [] = singDataCon trueName - allExp [one] = one - allExp (h:t) = AppE (AppE (singVal andName) h) (allExp t) - - (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 - -mkDecideMethClause :: Quasi q => (Con, Con) -> q Clause -mkDecideMethClause (c1, c2) - | lname == rname = - if lNumArgs == 0 - then return $ Clause [ConP lname [], ConP rname []] - (NormalB (AppE (ConE provedName) (ConE reflName))) [] - else do - lnames <- replicateM lNumArgs (qNewName "a") - rnames <- replicateM lNumArgs (qNewName "b") - contra <- qNewName "contra" - let lpats = map VarP lnames - rpats = map VarP rnames - lvars = map VarE lnames - rvars = map VarE rnames - return $ Clause - [ConP lname lpats, ConP rname rpats] - (NormalB $ - CaseE (mkTupleExp $ - zipWith (\l r -> foldExp (VarE sDecideMethName) [l, r]) - lvars rvars) - ((Match (mkTuplePat (replicate lNumArgs - (ConP provedName [ConP reflName []]))) - (NormalB $ AppE (ConE provedName) (ConE reflName)) - []) : - [Match (mkTuplePat (replicate i WildP ++ - ConP disprovedName [VarP contra] : - replicate (lNumArgs - i - 1) WildP)) - (NormalB $ AppE (ConE disprovedName) - (LamE [ConP reflName []] - (AppE (VarE contra) - (ConE reflName)))) - [] | i <- [0..lNumArgs-1] ])) - [] - - | otherwise = - return $ Clause - [ConP lname (replicate lNumArgs WildP), - ConP rname (replicate rNumArgs WildP)] - (NormalB (AppE (ConE disprovedName) (LamCaseE emptyMatches))) - [] - - where - (lname, lNumArgs) = extractNameArgs c1 - (rname, rNumArgs) = extractNameArgs c2 - --- the first parameter is True when we're refining the special case "Rep" --- and false otherwise. We wish to consider the promotion of "Rep" to be * --- not a promoted data constructor. -singDataD :: Quasi q => Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> q [Dec] -singDataD rep cxt name tvbs ctors derivings - | (_:_) <- cxt = fail "Singling of constrained datatypes is not supported" - | otherwise = do - aName <- qNewName "z" - let a = VarT aName - let tvbNames = map extractTvbName tvbs - k <- promoteType (foldType (ConT name) (map VarT tvbNames)) - (ctors', ctorInstDecls) <- evalForPair $ mapM (singCtor a) ctors - - -- instance for SingKind - fromSingClauses <- mapM mkFromSingClause ctors - toSingClauses <- mapM mkToSingClause ctors - let singKindInst = - InstanceD (map (singKindConstraint . VarT) tvbNames) - (AppT (ConT singKindClassName) - (kindParam k)) - [ mkTyFamInst demoteRepName - [kindParam k] - (foldType (ConT name) - (map (AppT demote . kindParam . VarT) tvbNames)) - , FunD fromSingName (fromSingClauses `orIfEmpty` emptyMethod aName) - , FunD toSingName (toSingClauses `orIfEmpty` emptyMethod aName) ] - - -- SEq instance - sEqInsts <- if elem eqName derivings - then mapM (mkEqualityInstance k ctors') [sEqClassDesc, sDecideClassDesc] - else return [] - - -- e.g. type SNat (a :: Nat) = Sing a - let kindedSynInst = - TySynD (singTyConName name) - [KindedTV aName k] - (AppT singFamily a) - - return $ (DataInstD [] singFamilyName [SigT a k] ctors' []) : - kindedSynInst : - singKindInst : - sEqInsts ++ - ctorInstDecls - where -- in the Rep case, the names of the constructors are in the wrong scope - -- (they're types, not datacons), so we have to reinterpret them. - mkConName :: Name -> Name - mkConName = if rep then reinterpret else id - - mkFromSingClause :: Quasi q => Con -> q Clause - mkFromSingClause c = do - let (cname, numArgs) = extractNameArgs c - varNames <- replicateM numArgs (qNewName "b") - return $ Clause [ConP (singDataConName cname) (map VarP varNames)] - (NormalB $ foldExp - (ConE $ mkConName cname) - (map (AppE (VarE fromSingName) . VarE) varNames)) - [] - - mkToSingClause :: Quasi q => Con -> q Clause - mkToSingClause = ctor1Case $ \cname types -> do - varNames <- mapM (const $ qNewName "b") types - svarNames <- mapM (const $ qNewName "c") types - promoted <- mapM promoteType types - let recursiveCalls = zipWith mkRecursiveCall varNames promoted - return $ - Clause [ConP (mkConName cname) (map VarP varNames)] - (NormalB $ - multiCase recursiveCalls - (map (ConP someSingDataName . listify . VarP) - svarNames) - (AppE (ConE someSingDataName) - (foldExp (ConE (singDataConName cname)) - (map VarE svarNames)))) - [] - - mkRecursiveCall :: Name -> Kind -> Exp - mkRecursiveCall var_name ki = - SigE (AppE (VarE toSingName) (VarE var_name)) - (AppT (ConT someSingDataName) (kindParam ki)) - - emptyMethod :: Name -> [Clause] - emptyMethod n = [Clause [VarP n] (NormalB $ CaseE (VarE n) emptyMatches) []] - -singKind :: Quasi q => Kind -> q (Kind -> Kind) -singKind (ForallT _ _ _) = - fail "Singling of explicitly quantified kinds not yet supported" -singKind (VarT _) = fail "Singling of kind variables not yet supported" -singKind (ConT _) = fail "Singling of named kinds not yet supported" -singKind (TupleT _) = fail "Singling of tuple kinds not yet supported" -singKind (UnboxedTupleT _) = fail "Unboxed tuple used as kind" -singKind ArrowT = fail "Singling of unsaturated arrow kinds not yet supported" -singKind ListT = fail "Singling of list kinds not yet supported" -singKind (AppT (AppT ArrowT k1) k2) = do - k1fn <- singKind k1 - k2fn <- singKind k2 - k <- qNewName "k" - return $ \f -> AppT (AppT ArrowT (k1fn (VarT k))) (k2fn (AppT f (VarT k))) -singKind (AppT _ _) = fail "Singling of kind applications not yet supported" -singKind (SigT _ _) = - fail "Singling of explicitly annotated kinds not yet supported" -singKind (LitT _) = fail "Type literal used as kind" -singKind (PromotedT _) = fail "Promoted data constructor used as kind" -singKind (PromotedTupleT _) = fail "Promoted tuple used as kind" -singKind PromotedNilT = fail "Promoted nil used as kind" -singKind PromotedConsT = fail "Promoted cons used as kind" -singKind StarT = return $ \k -> AppT (AppT ArrowT k) StarT -singKind ConstraintT = fail "Singling of constraint kinds not yet supported" - -singType :: Quasi q => Type -> q TypeFn -singType ty = do -- replace with singTypeRec [] ty after GHC bug #??? is fixed - sTypeFn <- singTypeRec [] ty - return $ \inner_ty -> liftOutForalls $ sTypeFn inner_ty - - -- the lifts all foralls to the top-level -liftOutForalls :: Type -> Type -liftOutForalls = - go [] [] [] - where - go tyvars cxt args (ForallT tyvars1 cxt1 t1) - = go (reverse tyvars1 ++ tyvars) (reverse cxt1 ++ cxt) args t1 - go tyvars cxt args (SigT t1 _kind) -- ignore these kind annotations, which have to be * - = go tyvars cxt args t1 - go tyvars cxt args (AppT (AppT ArrowT arg1) res1) - = go tyvars cxt (arg1 : args) res1 - go [] [] args t1 - = mk_fun_ty (reverse args) t1 - go tyvars cxt args t1 - = ForallT (reverse tyvars) (reverse cxt) (mk_fun_ty (reverse args) t1) - - mk_fun_ty [] res = res - mk_fun_ty (arg1:args) res = AppT (AppT ArrowT arg1) (mk_fun_ty args res) - --- the first parameter is the list of types the current type is applied to -singTypeRec :: Quasi q => TypeContext -> Type -> q TypeFn -singTypeRec (_:_) (ForallT _ _ _) = - fail "I thought this was impossible in Haskell. Email me at eir@cis.upenn.edu with your code if you see this message." -singTypeRec [] (ForallT _ [] ty) = -- Sing makes handling foralls automatic - singTypeRec [] ty -singTypeRec ctx (ForallT _tvbs cxt innerty) = do - cxt' <- singContext cxt - innerty' <- singTypeRec ctx innerty - return $ \ty -> ForallT [] cxt' (innerty' ty) -singTypeRec (_:_) (VarT _) = - fail "Singling of type variables of arrow kinds not yet supported" -singTypeRec [] (VarT _name) = - return $ \ty -> AppT singFamily ty -singTypeRec _ctx (ConT _name) = -- we don't need to process the context with Sing - return $ \ty -> AppT singFamily ty -singTypeRec _ctx (TupleT _n) = -- just like ConT - return $ \ty -> AppT singFamily ty -singTypeRec _ctx (UnboxedTupleT _n) = - fail "Singling of unboxed tuple types not yet supported" -singTypeRec ctx ArrowT = case ctx of - [ty1, ty2] -> do - t <- qNewName "t" - sty1 <- singTypeRec [] ty1 - sty2 <- singTypeRec [] ty2 - k1 <- promoteType ty1 - return (\f -> ForallT [KindedTV t k1] - [] - (AppT (AppT ArrowT (sty1 (VarT t))) - (sty2 (AppT f (VarT t))))) - _ -> fail "Internal error in Sing: converting ArrowT with improper context" -singTypeRec _ctx ListT = - return $ \ty -> AppT singFamily ty -singTypeRec ctx (AppT ty1 ty2) = - singTypeRec (ty2 : ctx) ty1 -- recur with the ty2 in the applied context -singTypeRec _ctx (SigT _ty _knd) = - fail "Singling of types with explicit kinds not yet supported" -singTypeRec _ctx (LitT _) = fail "Singling of type-level literals not yet supported" -singTypeRec _ctx (PromotedT _) = - fail "Singling of promoted data constructors not yet supported" -singTypeRec _ctx (PromotedTupleT _) = - fail "Singling of type-level tuples not yet supported" -singTypeRec _ctx PromotedNilT = fail "Singling of promoted nil not yet supported" -singTypeRec _ctx PromotedConsT = fail "Singling of type-level cons not yet supported" -singTypeRec _ctx StarT = fail "* used as type" -singTypeRec _ctx ConstraintT = fail "Constraint used as type" - --- refine a constraint context -singContext :: Quasi q => Cxt -> q Cxt -singContext = mapM singPred - -singPred :: Quasi q => Pred -> q Pred -singPred (ClassP name tys) = do - kis <- mapM promoteType tys - let sName = singClassName name - return $ ClassP sName (map kindParam kis) -singPred (EqualP _ty1 _ty2) = - fail "Singling of type equality constraints not yet supported" - -singClause :: Quasi q => ExpTable -> Clause -> q Clause -singClause vars (Clause pats (NormalB exp) []) = do - (sPats, vartbl) <- evalForPair $ mapM (singPat Parameter) pats - let vars' = Map.union vartbl vars - sBody <- NormalB <$> singExp vars' exp - return $ Clause sPats sBody [] -singClause _ (Clause _ (GuardedB _) _) = - fail "Singling of guarded patterns not yet supported" -singClause _ (Clause _ _ (_:_)) = - fail "Singling of <> declarations not yet supported" - -type ExpsQ q = QWithAux ExpTable q - --- we need to know where a pattern is to anticipate when --- GHC's brain might explode -data PatternContext = LetBinding - | CaseStatement - | TopLevel - | Parameter - | Statement - deriving Eq - -checkIfBrainWillExplode :: Quasi q => PatternContext -> ExpsQ q () -checkIfBrainWillExplode CaseStatement = return () -checkIfBrainWillExplode Statement = return () -checkIfBrainWillExplode Parameter = return () -checkIfBrainWillExplode _ = - fail $ "Can't use a singleton pattern outside of a case-statement or\n" ++ - "do expression: GHC's brain will explode if you try. (Do try it!)" - --- convert a pattern, building up the lexical scope as we go -singPat :: Quasi q => PatternContext -> Pat -> ExpsQ q Pat -singPat _patCxt (LitP _lit) = - fail "Singling of literal patterns not yet supported" -singPat patCxt (VarP name) = - let new = if patCxt == TopLevel then singValName name else name in do - addBinding name (VarE new) - return $ VarP new -singPat patCxt (TupP pats) = - singPat patCxt (ConP (tupleDataName (length pats)) pats) -singPat _patCxt (UnboxedTupP _pats) = - fail "Singling of unboxed tuples not supported" -singPat patCxt (ConP name pats) = do - checkIfBrainWillExplode patCxt - pats' <- mapM (singPat patCxt) pats - return $ ConP (singDataConName name) pats' -singPat patCxt (InfixP pat1 name pat2) = singPat patCxt (ConP name [pat1, pat2]) -singPat _patCxt (UInfixP _ _ _) = - fail "Singling of unresolved infix patterns not supported" -singPat _patCxt (ParensP _) = - fail "Singling of unresolved paren patterns not supported" -singPat patCxt (TildeP pat) = do - pat' <- singPat patCxt pat - return $ TildeP pat' -singPat patCxt (BangP pat) = do - pat' <- singPat patCxt pat - return $ BangP pat' -singPat patCxt (AsP name pat) = do - let new = if patCxt == TopLevel then singValName name else name in do - pat' <- singPat patCxt pat - addBinding name (VarE new) - return $ AsP name pat' -singPat _patCxt WildP = return WildP -singPat _patCxt (RecP _name _fields) = - fail "Singling of record patterns not yet supported" -singPat patCxt (ListP pats) = do - checkIfBrainWillExplode patCxt - sPats <- mapM (singPat patCxt) pats - return $ foldr (\elt lst -> ConP sconsName [elt, lst]) (ConP snilName []) sPats -singPat _patCxt (SigP _pat _ty) = - fail "Singling of annotated patterns not yet supported" -singPat _patCxt (ViewP _exp _pat) = - fail "Singling of view patterns not yet supported" - -singExp :: Quasi q => ExpTable -> Exp -> q Exp -singExp vars (VarE name) = case Map.lookup name vars of - Just exp -> return exp - Nothing -> return (singVal name) -singExp _vars (ConE name) = return $ singDataCon name -singExp _vars (LitE lit) = singLit lit -singExp vars (AppE exp1 exp2) = do - exp1' <- singExp vars exp1 - exp2' <- singExp vars exp2 - return $ AppE exp1' exp2' -singExp vars (InfixE mexp1 exp mexp2) = - case (mexp1, mexp2) of - (Nothing, Nothing) -> singExp vars exp - (Just exp1, Nothing) -> singExp vars (AppE exp exp1) - (Nothing, Just _exp2) -> - fail "Singling of right-only sections not yet supported" - (Just exp1, Just exp2) -> singExp vars (AppE (AppE exp exp1) exp2) -singExp _vars (UInfixE _ _ _) = - fail "Singling of unresolved infix expressions not supported" -singExp _vars (ParensE _) = - fail "Singling of unresolved paren expressions not supported" -singExp vars (LamE pats exp) = do - (pats', vartbl) <- evalForPair $ mapM (singPat Parameter) pats - let vars' = Map.union vartbl vars -- order matters; union is left-biased - exp' <- singExp vars' exp - return $ LamE pats' exp' -singExp _vars (LamCaseE _matches) = - fail "Singling of case expressions not yet supported" -singExp vars (TupE exps) = do - sExps <- mapM (singExp vars) exps - sTuple <- singExp vars (ConE (tupleDataName (length exps))) - return $ foldExp sTuple sExps -singExp _vars (UnboxedTupE _exps) = - fail "Singling of unboxed tuple not supported" -singExp vars (CondE bexp texp fexp) = do - exps <- mapM (singExp vars) [bexp, texp, fexp] - return $ foldExp (VarE sIfName) exps -singExp _vars (MultiIfE _alts) = - fail "Singling of multi-way if statements not yet supported" -singExp _vars (LetE _decs _exp) = - fail "Singling of let expressions not yet supported" -singExp _vars (CaseE _exp _matches) = - fail "Singling of case expressions not yet supported" -singExp _vars (DoE _stmts) = - fail "Singling of do expressions not yet supported" -singExp _vars (CompE _stmts) = - fail "Singling of list comprehensions not yet supported" -singExp _vars (ArithSeqE _range) = - fail "Singling of ranges not yet supported" -singExp vars (ListE exps) = do - sExps <- mapM (singExp vars) exps - return $ foldr (\x -> (AppE (AppE (ConE sconsName) x))) - (ConE snilName) sExps -singExp _vars (SigE _exp _ty) = - fail "Singling of annotated expressions not yet supported" -singExp _vars (RecConE _name _fields) = - fail "Singling of record construction not yet supported" -singExp _vars (RecUpdE _exp _fields) = - fail "Singling of record updates not yet supported" - -singLit :: Quasi q => Lit -> q Exp -singLit lit = SigE (VarE singMethName) <$> (AppT singFamily <$> (promoteLit lit)) diff --git a/Data/Singletons/TH.hs b/Data/Singletons/TH.hs deleted file mode 100644 --- a/Data/Singletons/TH.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces, CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TH --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- This module contains everything you need to derive your own singletons via --- Template Haskell. --- --- TURN ON @-XScopedTypeVariables@ IN YOUR MODULE IF YOU WANT THIS TO WORK. --- ----------------------------------------------------------------------------- - -module Data.Singletons.TH ( - -- * Primary Template Haskell generation functions - singletons, singletonsOnly, genSingletons, - promote, promoteOnly, - - -- ** Functions to generate equality instances - promoteEqInstances, promoteEqInstance, - singEqInstances, singEqInstance, - singEqInstancesOnly, singEqInstanceOnly, - singDecideInstances, singDecideInstance, - - -- ** Utility function - cases, - - -- * Basic singleton definitions - Sing(SFalse, STrue), SingI(..), SingKind(..), KindOf, Demote, - - -- * Auxiliary definitions - -- | These definitions might be mentioned in code generated by Template Haskell, - -- so they must be in scope. - - type (==), (:==), If, sIf, (:&&), SEq(..), - Any, - SDecide(..), (:~:)(..), Void, Refuted, Decision(..), - KProxy(..), SomeSing(..) - ) where - -import Data.Singletons.Singletons -import Data.Singletons.Promote -import Data.Singletons.Core -import Data.Singletons.Bool -import Data.Singletons.Eq -import Data.Singletons.Types -import Data.Singletons.Void - -import GHC.Exts -import Language.Haskell.TH -import Language.Haskell.TH.Syntax ( Quasi(..) ) -import Language.Haskell.TH.Desugar -import Data.Singletons.Util -import Control.Applicative - -#if __GLASGOW_HASKELL__ >= 707 -import Data.Type.Equality -import Data.Proxy -#endif - --- | The function 'cases' generates a case expression where each right-hand side --- is identical. This may be useful if the type-checker requires knowledge of which --- constructor is used to satisfy equality or type-class constraints, but where --- each constructor is treated the same. -cases :: Quasi q - => Name -- ^ The head of the type of the scrutinee. (Like @''Maybe@ or @''Bool@.) - -> q Exp -- ^ The scrutinee, in a Template Haskell quote - -> q Exp -- ^ The body, in a Template Haskell quote - -> q Exp -cases tyName expq bodyq = do - info <- reifyWithWarning tyName - case info of - TyConI (DataD _ _ _ ctors _) -> buildCases ctors - TyConI (NewtypeD _ _ _ ctor _) -> buildCases [ctor] - _ -> fail $ "Using <> with something other than a type constructor: " - ++ (show tyName) - where buildCases ctors = - CaseE <$> expq <*> - mapM (\con -> Match (conToPat con) <$> - (NormalB <$> bodyq) <*> pure []) ctors - - conToPat :: Con -> Pat - conToPat = ctor1Case - (\name tys -> ConP name (map (const WildP) tys)) diff --git a/Data/Singletons/Tuple.hs b/Data/Singletons/Tuple.hs deleted file mode 100644 --- a/Data/Singletons/Tuple.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, DataKinds, PolyKinds, - RankNTypes, TypeFamilies, GADTs, CPP #-} - -#if __GLASGOW_HASKELL__ < 707 -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Tuple --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines functions and datatypes relating to the singleton for tuples, --- including a singletons version of all the definitions in @Data.Tuple@. --- --- Because many of these definitions are produced by Template Haskell, --- it is not possible to create proper Haddock documentation. Please look --- up the corresponding operation in @Data.Tuple@. Also, please excuse --- the apparent repeated variable names. This is due to an interaction --- between Template Haskell and Haddock. --- ----------------------------------------------------------------------------- - -module Data.Singletons.Tuple ( - -- * Singleton definitions - -- | See 'Data.Singletons.Prelude.Sing' for more info. - Sing(STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7), - STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7, - - -- * Singletons from @Data.Tuple@ - Fst, sFst, Snd, sSnd, Curry, sCurry, Uncurry, sUncurry, Swap, sSwap - ) where - -import Data.Singletons.Core -import Data.Singletons.TH - -$(singletonsOnly [d| - -- | Extract the first component of a pair. - fst :: (a,b) -> a - fst (x,_) = x - - -- | Extract the second component of a pair. - snd :: (a,b) -> b - snd (_,y) = y - - -- | 'curry' converts an uncurried function to a curried function. - curry :: ((a, b) -> c) -> a -> b -> c - curry f x y = f (x, y) - - -- | 'uncurry' converts a curried function to a function on pairs. - uncurry :: (a -> b -> c) -> ((a, b) -> c) - uncurry f p = f (fst p) (snd p) - - -- | Swap the components of a pair. - swap :: (a,b) -> (b,a) - swap (a,b) = (b,a) - |]) diff --git a/Data/Singletons/TypeRepStar.hs b/Data/Singletons/TypeRepStar.hs deleted file mode 100644 --- a/Data/Singletons/TypeRepStar.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE RankNTypes, TypeFamilies, KindSignatures, FlexibleInstances, - GADTs, UndecidableInstances, ScopedTypeVariables, DataKinds, - MagicHash, CPP, TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.TypeRepStar --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- This module defines singleton instances making 'Typeable' the singleton for --- the kind @*@. The definitions don't fully line up with what is expected --- within the singletons library, so expect unusual results! --- ----------------------------------------------------------------------------- - -module Data.Singletons.TypeRepStar ( - Sing(STypeRep) - -- | Here is the definition of the singleton for @*@: - -- - -- > data instance Sing (a :: *) where - -- > STypeRep :: Typeable a => Sing a - -- - -- Instances for 'SingI', 'SingKind', 'SEq', 'SDecide', and 'TestCoercion' are - -- also supplied. - ) where - -import Data.Singletons.Core -import Data.Singletons.Types -import Data.Singletons.Eq -import Data.Typeable -import Unsafe.Coerce - -#if __GLASGOW_HASKELL__ >= 707 -import GHC.Exts ( Proxy# ) -import Data.Type.Coercion -import Data.Proxy -#else - -eqT :: (Typeable a, Typeable b) => Maybe (a :~: b) -eqT = gcast Refl - -type instance (a :: *) :== (a :: *) = True - -#endif - -data instance Sing (a :: *) where - STypeRep :: Typeable a => Sing a - -instance Typeable a => SingI (a :: *) where - sing = STypeRep -instance SingKind ('KProxy :: KProxy *) where - type DemoteRep ('KProxy :: KProxy *) = TypeRep - fromSing (STypeRep :: Sing a) = typeOf (undefined :: a) - toSing = dirty_mk_STypeRep - -instance SEq ('KProxy :: KProxy *) where - (STypeRep :: Sing a) %:== (STypeRep :: Sing b) = - case (eqT :: Maybe (a :~: b)) of - Just Refl -> STrue - Nothing -> unsafeCoerce SFalse - -- the Data.Typeable interface isn't strong enough - -- to enable us to define this without unsafeCoerce - -instance SDecide ('KProxy :: KProxy *) where - (STypeRep :: Sing a) %~ (STypeRep :: Sing b) = - case (eqT :: Maybe (a :~: b)) of - Just Refl -> Proved Refl - Nothing -> Disproved (\Refl -> error "Data.Typeable.eqT failed") - -#if __GLASGOW_HASKELL__ >= 707 --- TestEquality instance already defined, but we need this one: -instance TestCoercion Sing where - testCoercion (STypeRep :: Sing a) (STypeRep :: Sing b) = - case (eqT :: Maybe (a :~: b)) of - Just Refl -> Just Coercion - Nothing -> Nothing -#endif - --- everything below here is private and dirty. Don't look! - -newtype DI = Don'tInstantiate (Typeable a => Sing a) -dirty_mk_STypeRep :: TypeRep -> SomeSing ('KProxy :: KProxy *) -dirty_mk_STypeRep rep = -#if __GLASGOW_HASKELL__ >= 707 - let justLikeTypeable :: Proxy# a -> TypeRep - justLikeTypeable _ = rep - in -#else - let justLikeTypeable :: a -> TypeRep - justLikeTypeable _ = rep - in -#endif - unsafeCoerce (Don'tInstantiate STypeRep) justLikeTypeable diff --git a/Data/Singletons/Types.hs b/Data/Singletons/Types.hs deleted file mode 100644 --- a/Data/Singletons/Types.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE PolyKinds, TypeOperators, GADTs, RankNTypes, TypeFamilies, - CPP, DataKinds #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Types --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines and exports types that are useful when working with singletons. --- Some of these are re-exports from @Data.Type.Equality@. --- ----------------------------------------------------------------------------- - - -module Data.Singletons.Types ( - Refuted, Decision(..), -#if __GLASGOW_HASKELL__ < 707 - KProxy(..), Proxy(..), - (:~:)(..), gcastWith, TestEquality(..) -#endif - ) where - -import Data.Singletons.Void - -#if __GLASGOW_HASKELL__ < 707 - --- now in Data.Proxy -data KProxy (a :: *) = KProxy -data Proxy a = Proxy - --- now in Data.Type.Equality -data a :~: b where - Refl :: a :~: a - -gcastWith :: (a :~: b) -> ((a ~ b) => r) -> r -gcastWith Refl x = x - -class TestEquality (f :: k -> *) where - testEquality :: f a -> f b -> Maybe (a :~: b) - -#endif - --- | Because we can never create a value of type 'Void', a function that type-checks --- at @a -> Void@ shows that objects of type @a@ can never exist. Thus, we say that --- @a@ is 'Refuted' -type Refuted a = (a -> Void) - --- | A 'Decision' about a type @a@ is either a proof of existence or a proof that @a@ --- cannot exist. -data Decision a = Proved a -- ^ Witness for @a@ - | Disproved (Refuted a) -- ^ Proof that no @a@ exists diff --git a/Data/Singletons/Util.hs b/Data/Singletons/Util.hs deleted file mode 100644 --- a/Data/Singletons/Util.hs +++ /dev/null @@ -1,274 +0,0 @@ -{- Data/Singletons/Util.hs - -(c) Richard Eisenberg 2013 -eir@cis.upenn.edu - -This file contains helper functions internal to the singletons package. -Users of the package should not need to consult this file. --} - -{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, RankNTypes, - TemplateHaskell, GeneralizedNewtypeDeriving, - MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} - -module Data.Singletons.Util ( - module Data.Singletons.Util, - module Language.Haskell.TH.Desugar ) - where - -import Prelude hiding ( exp ) -import Language.Haskell.TH hiding ( Q ) -import Language.Haskell.TH.Syntax ( Quasi(..) ) -import Language.Haskell.TH.Desugar ( reifyWithWarning, getDataD ) -import Data.Char -import Data.Data -import Control.Monad -import Control.Applicative -import Control.Monad.Writer -import qualified Data.Map as Map -import Data.Generics - -mkTyFamInst :: Name -> [Type] -> Type -> Dec -mkTyFamInst name lhs rhs = -#if __GLASGOW_HASKELL__ >= 707 - TySynInstD name (TySynEqn lhs rhs) -#else - TySynInstD name lhs rhs -#endif - --- The list of types that singletons processes by default -basicTypes :: [Name] -basicTypes = [ ''Bool - , ''Maybe - , ''Either - , ''Ordering - , ''[] - , ''() - , ''(,) - , ''(,,) - , ''(,,,) - , ''(,,,,) - , ''(,,,,,) - , ''(,,,,,,) - ] - --- like newName, but even more unique (unique across different splices) --- TH doesn't allow "newName"s to work at the top-level, so we have to --- do this trick to ensure the Extract functions are unique -newUniqueName :: Quasi q => String -> q Name -newUniqueName str = do - n <- qNewName str - return $ mkName $ show n - --- like reportWarning, but generalized to any Quasi -qReportWarning :: Quasi q => String -> q () -qReportWarning = qReport False - --- extract the degree of a tuple -tupleDegree_maybe :: String -> Maybe Int -tupleDegree_maybe s = do - '(' : s1 <- return s - (commas, ")") <- return $ span (== ',') s1 - let degree - | "" <- commas = 0 - | otherwise = length commas + 1 - return degree - --- extract the degree of a tuple name -tupleNameDegree_maybe :: Name -> Maybe Int -tupleNameDegree_maybe = tupleDegree_maybe . nameBase - --- reduce the four cases of a 'Con' to just two: monomorphic and polymorphic --- and convert 'StrictType' to 'Type' -ctorCases :: (Name -> [Type] -> a) -> ([TyVarBndr] -> Cxt -> Con -> a) -> Con -> a -ctorCases genFun forallFun ctor = case ctor of - NormalC name stypes -> genFun name (map snd stypes) - RecC name vstypes -> genFun name (map (\(_,_,ty) -> ty) vstypes) - InfixC (_,ty1) name (_,ty2) -> genFun name [ty1, ty2] - ForallC [] [] ctor' -> ctorCases genFun forallFun ctor' - ForallC tvbs cx ctor' -> forallFun tvbs cx ctor' - --- reduce the four cases of a 'Con' to just 1: a polymorphic Con is treated --- as a monomorphic one -ctor1Case :: (Name -> [Type] -> a) -> Con -> a -ctor1Case mono = ctorCases mono (\_ _ ctor -> ctor1Case mono ctor) - --- extract the name and number of arguments to a constructor -extractNameArgs :: Con -> (Name, Int) -extractNameArgs = ctor1Case (\name tys -> (name, length tys)) - --- reinterpret a name. This is useful when a Name has an associated --- namespace that we wish to forget -reinterpret :: Name -> Name -reinterpret = mkName . nameBase - --- is an identifier uppercase? -isUpcase :: Name -> Bool -isUpcase n = let first = head (nameBase n) in isUpper first || first == ':' - --- make an identifier uppercase -upcase :: Name -> Name -upcase n = - let str = nameBase n - first = head str in - if isLetter first - then mkName ((toUpper first) : tail str) - else mkName (':' : str) - --- make an identifier lowercase -locase :: Name -> Name -locase n = - let str = nameBase n - first = head str in - if isLetter first - then mkName ((toLower first) : tail str) - else mkName (tail str) -- remove the ":" - --- put an uppercase prefix on a name. Takes two prefixes: one for identifiers --- and one for symbols -prefixUCName :: String -> String -> Name -> Name -prefixUCName pre tyPre n = case (nameBase n) of - (':' : rest) -> mkName (tyPre ++ rest) - alpha -> mkName (pre ++ alpha) - --- put a lowercase prefix on a name. Takes two prefixes: one for identifiers --- and one for symbols -prefixLCName :: String -> String -> Name -> Name -prefixLCName pre tyPre n = - let str = nameBase n - first = head str in - if isLetter first - then mkName (pre ++ str) - else mkName (tyPre ++ str) - --- extract the kind from a TyVarBndr. Returns '*' by default. -extractTvbKind :: TyVarBndr -> Kind -extractTvbKind (PlainTV _) = StarT -- FIXME: This seems wrong. -extractTvbKind (KindedTV _ k) = k - --- extract the name from a TyVarBndr. -extractTvbName :: TyVarBndr -> Name -extractTvbName (PlainTV n) = n -extractTvbName (KindedTV n _) = n - --- apply a type to a list of types -foldType :: Type -> [Type] -> Type -foldType = foldl AppT - --- apply an expression to a list of expressions -foldExp :: Exp -> [Exp] -> Exp -foldExp = foldl AppE - --- is a kind a variable? -isVarK :: Kind -> Bool -isVarK (VarT _) = True -isVarK _ = False - --- tuple up a list of expressions -mkTupleExp :: [Exp] -> Exp -mkTupleExp [x] = x -mkTupleExp xs = TupE xs - --- tuple up a list of patterns -mkTuplePat :: [Pat] -> Pat -mkTuplePat [x] = x -mkTuplePat xs = TupP xs - --- choose the first non-empty list -orIfEmpty :: [a] -> [a] -> [a] -orIfEmpty [] x = x -orIfEmpty x _ = x - --- an empty list of matches, compatible with GHC 7.6.3 -emptyMatches :: [Match] -#if __GLASGOW_HASKELL__ >= 707 -emptyMatches = [] -#else -emptyMatches = [Match WildP (NormalB (AppE (VarE 'error) (LitE (StringL errStr)))) []] - where errStr = "Empty case reached -- this should be impossible" -#endif - --- build a pattern match over several expressions, each with only one pattern -multiCase :: [Exp] -> [Pat] -> Exp -> Exp -multiCase [] [] body = body -multiCase scruts pats body = - CaseE (mkTupleExp scruts) - [Match (mkTuplePat pats) (NormalB body) []] - --- a monad transformer for writing a monoid alongside returning a Q -newtype QWithAux m q a = QWA { runQWA :: WriterT m q a } - deriving (Functor, Applicative, Monad, MonadTrans) - -instance (Monoid m, Monad q) => MonadWriter m (QWithAux m q) where - writer = QWA . writer - tell = QWA . tell - listen = QWA . listen . runQWA - pass = QWA . pass . runQWA - --- make a Quasi instance for easy lifting -instance (Quasi q, Monoid m) => Quasi (QWithAux m q) where - qNewName = lift `comp1` qNewName - qReport = lift `comp2` qReport - qLookupName = lift `comp2` qLookupName - qReify = lift `comp1` qReify - qReifyInstances = lift `comp2` qReifyInstances - qLocation = lift qLocation - qRunIO = lift `comp1` qRunIO - qAddDependentFile = lift `comp1` qAddDependentFile -#if __GLASGOW_HASKELL__ >= 707 - qReifyRoles = lift `comp1` qReifyRoles - qReifyAnnotations = lift `comp1` qReifyAnnotations - qReifyModule = lift `comp1` qReifyModule - qAddTopDecls = lift `comp1` qAddTopDecls - qAddModFinalizer = lift `comp1` qAddModFinalizer - qGetQ = lift qGetQ - qPutQ = lift `comp1` qPutQ -#endif - - qRecover exp handler = do - (result, aux) <- lift $ qRecover (evalForPair exp) (evalForPair handler) - tell aux - return result - --- helper functions for composition -comp1 :: (b -> c) -> (a -> b) -> a -> c -comp1 = (.) - -comp2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d -comp2 f g a b = f (g a b) - --- run a computation with an auxiliary monoid, discarding the monoid result -evalWithoutAux :: Quasi q => QWithAux m q a -> q a -evalWithoutAux = liftM fst . runWriterT . runQWA - --- run a computation with an auxiliary monoid, returning only the monoid result -evalForAux :: Quasi q => QWithAux m q a -> q m -evalForAux = execWriterT . runQWA - --- run a computation with an auxiliary monoid, return both the result --- of the computation and the monoid result -evalForPair :: Quasi q => QWithAux m q a -> q (a, m) -evalForPair = runWriterT . runQWA - --- in a computation with an auxiliary map, add a binding to the map -addBinding :: (Quasi q, Ord k) => k -> v -> QWithAux (Map.Map k v) q () -addBinding k v = tell (Map.singleton k v) - --- in a computation with an auxiliar list, add an element to the list -addElement :: Quasi q => elt -> QWithAux [elt] q () -addElement elt = tell [elt] - --- does a TH structure contain a name? -containsName :: Data a => Name -> a -> Bool -containsName n = everything (||) (mkQ False (== n)) - --- lift concatMap into a monad -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM fn list = do - bss <- mapM fn list - return $ concat bss - --- make a one-element list -listify :: a -> [a] -listify = return diff --git a/Data/Singletons/Void.hs b/Data/Singletons/Void.hs deleted file mode 100644 --- a/Data/Singletons/Void.hs +++ /dev/null @@ -1,78 +0,0 @@ -{- Data/Singletons/Void.hs - - A reimplementation of a Void type, copied shamelessly from Edward Kmett's void - package, but without inducing a dependency. - --} - -{-# LANGUAGE CPP, Trustworthy, DeriveDataTypeable, DeriveGeneric, StandaloneDeriving #-} - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2008-2013 Edward Kmett --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- This module is a reimplementation of Edward Kmett's @void@ package. --- It is included within singletons to avoid depending on @void@ and all the --- packages that depends on (including @text@). If this causes problems for --- you (that singletons has its own 'Void' type), please let me (Richard Eisenberg) --- know at @eir@ at @cis.upenn.edu@. --- ----------------------------------------------------------------------------- -module Data.Singletons.Void - ( Void - , absurd - , vacuous - , vacuousM - ) where - -import Control.Monad (liftM) -import Data.Ix -import Data.Data -import GHC.Generics -import Control.Exception - --- | A logically uninhabited data type. -newtype Void = Void Void - deriving (Data, Typeable, Generic) - -instance Eq Void where - _ == _ = True - -instance Ord Void where - compare _ _ = EQ - -instance Show Void where - showsPrec _ = absurd - --- | Reading a 'Void' value is always a parse error, considering 'Void' as --- a data type with no constructors. -instance Read Void where - readsPrec _ _ = [] - --- | Since 'Void' values logically don't exist, this witnesses the logical --- reasoning tool of \"ex falso quodlibet\". -absurd :: Void -> a -absurd a = a `seq` spin a where - spin (Void b) = spin b - --- | If 'Void' is uninhabited then any 'Functor' that holds only values of type 'Void' --- is holding no values. -vacuous :: Functor f => f Void -> f a -vacuous = fmap absurd - --- | If 'Void' is uninhabited then any 'Monad' that holds values of type 'Void' --- is holding no values. -vacuousM :: Monad m => m Void -> m a -vacuousM = liftM absurd - -instance Ix Void where - range _ = [] - index _ = absurd - inRange _ = absurd - rangeSize _ = 0 - -instance Exception Void diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,8 @@ -singletons 0.9.3 -================ +singletons 0.10 +=============== +[![Build Status](https://travis-ci.org/goldfirere/singletons.svg?branch=master)](https://travis-ci.org/goldfirere/singletons) + This is the README file for the singletons library. This file contains all the documentation for the definitions and functions in the library. @@ -36,8 +38,41 @@ * `RankNTypes` * `UndecidableInstances` * `FlexibleInstances` -* `EmptyCase` (for GHC 7.8) +Modules +------- + +`Data.Singletons` exports all the basic singletons definitions. Import this +module if you are not using Template Haskell and wish only to define your +own singletons. + +`Data.Singletons.TH` exports all the definitions needed to use the Template +Haskell code to generate new singletons. + +`Data.Singletons.Prelude` re-exports `Data.Singletons` along with singleton +definitions for various Prelude types. This module is intended to export +those definitions that are exported by the real `Prelude`. + +There are several modules that echo standard modules. For example, +`Data.Singletons.Maybe` exports singleton definitions for `Data.Maybe`. +These modules are: `List` (many definitions are missing), `Bool`, +`Maybe`, `Either`, `Tuple`. + +`Data.Singletons.Eq` and `Data.Singletons.Decide` export type classes for +Boolean and propositional equality, respectively. + +`Data.Singletons.TypeLits` exports definitions for working with `GHC.TypeLits`. +In GHC 7.6.3, `Data.Singletons.TypeLits` defines and exports `KnownNat` and +`KnownSymbol`, which are part of `GHC.TypeLits` in GHC 7.8. This makes cross-version +support a little easier. + +`Data.Singletons.Void` exports a `Void` type, shamelessly copied from +Edward Kmett's `void` package, but without the great many package dependencies +in `void`. + +`Data.Singletons.Types` exports a few type-level definitions that are in +`base` for GHC 7.8, but not in GHC 7.6.3. By importing this package, users +of both GHC versions can access these definitions. Functions to generate singletons -------------------------------- diff --git a/singletons.cabal b/singletons.cabal --- a/singletons.cabal +++ b/singletons.cabal @@ -1,5 +1,6 @@ name: singletons -version: 0.9.3 +version: 0.10.0 + -- Remember to bump version in the Makefile as well cabal-version: >= 1.10 synopsis: A framework for generating singleton types homepage: http://www.cis.upenn.edu/~eir/packages/singletons @@ -8,7 +9,21 @@ maintainer: Richard Eisenberg bug-reports: https://github.com/goldfirere/singletons/issues stability: experimental -extra-source-files: README.md, CHANGES.md +tested-with: GHC ==7.6.3, GHC ==7.8.* +extra-source-files: README.md, CHANGES.md, + tests/compile-and-dump/buildGoldenFiles.awk, + tests/compile-and-dump/GradingClient/*.hs, + tests/compile-and-dump/InsertionSort/*.hs, + tests/compile-and-dump/Promote/*.hs, + tests/compile-and-dump/Singletons/*.hs + tests/compile-and-dump/GradingClient/*.ghc76.template, + tests/compile-and-dump/InsertionSort/*.ghc76.template, + tests/compile-and-dump/Promote/*.ghc76.template, + tests/compile-and-dump/Singletons/*.ghc76.template, + tests/compile-and-dump/GradingClient/*.ghc78.template, + tests/compile-and-dump/InsertionSort/*.ghc78.template, + tests/compile-and-dump/Promote/*.ghc78.template, + tests/compile-and-dump/Singletons/*.ghc78.template license: BSD3 license-file: LICENSE build-type: Simple @@ -21,22 +36,21 @@ () The Haddock documentation does not build with the Haddock distributed with - GHC 7.6.x, but it does build with HEAD. Please see links from the project + GHC 7.6.x, but it does build with 7.8.1. Please see links from the project homepage to find the built documentation. source-repository this type: git location: https://github.com/goldfirere/singletons.git - tag: v0.9.3 + tag: v0.10.0 library - build-depends: - base >= 4.6 && < 5, - mtl >= 2.1.1, - template-haskell, - containers >= 0.5, - syb >= 0.3, - th-desugar >= 1.2 + hs-source-dirs: src + build-depends: base >= 4.6 && < 5, + mtl >= 2.1.1, + template-haskell, + containers >= 0.5, + th-desugar >= 1.2 default-language: Haskell2010 exposed-modules: Data.Singletons, Data.Singletons.CustomStar, @@ -50,27 +64,29 @@ Data.Singletons.Eq, Data.Singletons.Prelude, Data.Singletons.Types, + Data.Singletons.TypeLits, Data.Singletons.Decide, Data.Singletons.Void other-modules: Data.Singletons.Promote, Data.Singletons.Singletons, Data.Singletons.Util, - Data.Singletons.Core + Data.Singletons.Instances --- This DOES NOT WORK with GHC HEAD because of -dynamic-too problems --- test-suite compile --- type: exitcode-stdio-1.0 --- ghc-options: -Wall -Werror -main-is Test.Main --- default-language: Haskell2010 --- main-is: Test/Main.hs + ghc-options: -Wall --- build-depends: --- base >= 4.6 && < 5, --- constraints >= 0.3, --- containers >= 0.5, --- syb >= 0.3, --- mtl >= 2.1.1, --- th-desugar >= 1.2, --- template-haskell - +test-suite singletons-test-suite + type: exitcode-stdio-1.0 + hs-source-dirs: src, tests + ghc-options: -Wall + default-language: Haskell2010 + main-is: SingletonsTestSuite.hs + other-modules: SingletonsTestSuiteUtils + + build-depends: base >= 4.6 && < 5, + constraints, + filepath >= 1.3, + process >= 1.1, + tasty >= 0.6, + tasty-golden >= 2.2, + Cabal >= 1.16 diff --git a/src/Data/Singletons.hs b/src/Data/Singletons.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE MagicHash, RankNTypes, PolyKinds, GADTs, DataKinds, + FlexibleContexts, CPP, TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- This module exports the basic definitions to use singletons. For routine +-- use, consider importing 'Data.Singletons.Prelude', which exports constructors +-- for singletons based on types in the @Prelude@. +-- +-- You may also want to read +-- and the +-- original paper presenting this library, available at +-- . +-- +---------------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ < 707 + -- optimizing instances of SDecide cause GHC to die (#8467) +{-# OPTIONS_GHC -O0 #-} +#endif + +module Data.Singletons ( + -- * Main singleton definitions + + Sing, + -- | See also 'Data.Singletons.Prelude.Sing' for exported constructors + + SingI(..), SingKind(..), + + -- * Working with singletons + KindOf, Demote, + SingInstance(..), SomeSing(..), + singInstance, withSingI, withSomeSing, singByProxy, + +#if __GLASGOW_HASKELL__ >= 707 + singByProxy#, +#endif + withSing, singThat, + + -- * Auxiliary functions + bugInGHC, + KProxy(..), Proxy(..) + ) where + +import Unsafe.Coerce + +#if __GLASGOW_HASKELL__ >= 707 +import GHC.Exts ( Proxy# ) +import Data.Proxy +#else +import Data.Singletons.Types +#endif + +-- | Convenient synonym to refer to the kind of a type variable: +-- @type KindOf (a :: k) = ('KProxy :: KProxy k)@ +type KindOf (a :: k) = ('KProxy :: KProxy k) + +---------------------------------------------------------------------- +---- Sing & friends -------------------------------------------------- +---------------------------------------------------------------------- + +-- | The singleton kind-indexed data family. +data family Sing (a :: k) + +-- | A 'SingI' constraint is essentially an implicitly-passed singleton. +-- If you need to satisfy this constraint with an explicit singleton, please +-- see 'withSingI'. +class SingI (a :: k) where + -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ + -- extension to use this method the way you want. + sing :: Sing a + +-- | The 'SingKind' class is essentially a /kind/ class. It classifies all kinds +-- for which singletons are defined. The class supports converting between a singleton +-- type and the base (unrefined) type which it is built from. +class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where + -- | Get a base type from a proxy for the promoted kind. For example, + -- @DemoteRep ('KProxy :: KProxy Bool)@ will be the type @Bool@. + type DemoteRep kparam :: * + + -- | Convert a singleton to its unrefined version. + fromSing :: Sing (a :: k) -> DemoteRep kparam + + -- | Convert an unrefined type to an existentially-quantified singleton type. + toSing :: DemoteRep kparam -> SomeSing kparam + +-- | Convenient abbreviation for 'DemoteRep': +-- @type Demote (a :: k) = DemoteRep ('KProxy :: KProxy k)@ +type Demote (a :: k) = DemoteRep ('KProxy :: KProxy k) + +-- | An /existentially-quantified/ singleton. This type is useful when you want a +-- singleton type, but there is no way of knowing, at compile-time, what the type +-- index will be. To make use of this type, you will generally have to use a +-- pattern-match: +-- +-- > foo :: Bool -> ... +-- > foo b = case toSing b of +-- > SomeSing sb -> {- fancy dependently-typed code with sb -} +-- +-- An example like the one above may be easier to write using 'withSomeSing'. +data SomeSing (kproxy :: KProxy k) where + SomeSing :: Sing (a :: k) -> SomeSing ('KProxy :: KProxy k) + +---------------------------------------------------------------------- +---- SingInstance ---------------------------------------------------- +---------------------------------------------------------------------- + +-- | A 'SingInstance' wraps up a 'SingI' instance for explicit handling. +data SingInstance (a :: k) where + SingInstance :: SingI a => SingInstance a + +-- dirty implementation of explicit-to-implicit conversion +newtype DI a = Don'tInstantiate (SingI a => SingInstance a) + +-- | Get an implicit singleton (a 'SingI' instance) from an explicit one. +singInstance :: forall (a :: k). Sing a -> SingInstance a +singInstance s = with_sing_i SingInstance + where + with_sing_i :: (SingI a => SingInstance a) -> SingInstance a + with_sing_i si = unsafeCoerce (Don'tInstantiate si) s + +---------------------------------------------------------------------- +---- Convenience ----------------------------------------------------- +---------------------------------------------------------------------- + +-- | Convenience function for creating a context with an implicit singleton +-- available. +withSingI :: Sing n -> (SingI n => r) -> r +withSingI sn r = + case singInstance sn of + SingInstance -> r + +-- | Convert a normal datatype (like 'Bool') to a singleton for that datatype, +-- passing it into a continuation. +withSomeSing :: SingKind ('KProxy :: KProxy k) + => DemoteRep ('KProxy :: KProxy k) -- ^ The original datatype + -> (forall (a :: k). Sing a -> r) -- ^ Function expecting a singleton + -> r +withSomeSing x f = + case toSing x of + SomeSing x' -> f x' + +-- | A convenience function useful when we need to name a singleton value +-- multiple times. Without this function, each use of 'sing' could potentially +-- refer to a different singleton, and one has to use type signatures (often +-- with @ScopedTypeVariables@) to ensure that they are the same. +withSing :: SingI a => (Sing a -> b) -> b +withSing f = f sing + +-- | A convenience function that names a singleton satisfying a certain +-- property. If the singleton does not satisfy the property, then the function +-- returns 'Nothing'. The property is expressed in terms of the underlying +-- representation of the singleton. +singThat :: forall (a :: k). (SingKind ('KProxy :: KProxy k), SingI a) + => (Demote a -> Bool) -> Maybe (Sing a) +singThat p = withSing $ \x -> if p (fromSing x) then Just x else Nothing + +-- | Allows creation of a singleton when a proxy is at hand. +singByProxy :: SingI a => proxy a -> Sing a +singByProxy _ = sing + +#if __GLASGOW_HASKELL__ >= 707 +-- | Allows creation of a singleton when a @proxy#@ is at hand. +singByProxy# :: SingI a => Proxy# a -> Sing a +singByProxy# _ = sing +#endif + +-- | GHC 7.8 sometimes warns about incomplete pattern matches when no such +-- patterns are possible, due to GADT constraints. +-- See the bug report at . +-- In such cases, it's useful to have a catch-all pattern that then has +-- 'bugInGHC' as its right-hand side. +bugInGHC :: forall a. a +bugInGHC = error "Bug encountered in GHC -- this should never happen" + diff --git a/src/Data/Singletons/Bool.hs b/src/Data/Singletons/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Bool.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds, TypeFamilies, TypeOperators, + GADTs, CPP #-} + +#if __GLASGOW_HASKELL__ < 707 +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.Bool +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines functions and datatypes relating to the singleton for 'Bool', +-- including a singletons version of all the definitions in @Data.Bool@. +-- +-- Because many of these definitions are produced by Template Haskell, +-- it is not possible to create proper Haddock documentation. Please look +-- up the corresponding operation in @Data.Bool@. Also, please excuse +-- the apparent repeated variable names. This is due to an interaction +-- between Template Haskell and Haddock. +-- +---------------------------------------------------------------------------- + +module Data.Singletons.Bool ( + -- * The 'Bool' singleton + + Sing(SFalse, STrue), + -- | Though Haddock doesn't show it, the 'Sing' instance above declares + -- constructors + -- + -- > SFalse :: Sing False + -- > STrue :: Sing True + + SBool, + -- | 'SBool' is a kind-restricted synonym for 'Sing': @type SBool (a :: Bool) = Sing a@ + + -- * Conditionals + If, sIf, + + -- * Singletons from @Data.Bool@ + Not, sNot, (:&&), (:||), (%:&&), (%:||), + + -- | The following are derived from the function 'bool' in @Data.Bool@. The extra + -- underscore is to avoid name clashes with the type 'Bool'. + Bool_, sBool_, Otherwise, sOtherwise + ) where + +import Data.Singletons +import Data.Singletons.Instances +import Data.Singletons.Singletons +import Data.Singletons.Types + +#if __GLASGOW_HASKELL__ >= 707 +import Data.Type.Bool + +type a :&& b = a && b +type a :|| b = a || b + +(%:&&) :: SBool a -> SBool b -> SBool (a :&& b) +SFalse %:&& _ = SFalse +STrue %:&& a = a + +(%:||) :: SBool a -> SBool b -> SBool (a :|| b) +SFalse %:|| a = a +STrue %:|| _ = STrue + +#else + +$(singletonsOnly [d| + (&&) :: Bool -> Bool -> Bool + False && _ = False + True && x = x + + (||) :: Bool -> Bool -> Bool + False || x = x + True || _ = True + |]) + +#endif + +sNot :: SBool a -> SBool (Not a) +sNot SFalse = STrue +sNot STrue = SFalse + +-- | Conditional over singletons +sIf :: Sing a -> Sing b -> Sing c -> Sing (If a b c) +sIf STrue b _ = b +sIf SFalse _ c = c + +-- ... with some functions over Booleans +$(singletonsOnly [d| + bool_ :: a -> a -> Bool -> a + bool_ fls _tru False = fls + bool_ _fls tru True = tru + + otherwise :: Bool + otherwise = True + |]) diff --git a/src/Data/Singletons/CustomStar.hs b/src/Data/Singletons/CustomStar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/CustomStar.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE DataKinds, TypeFamilies, KindSignatures, CPP, TemplateHaskell #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.CustomStar +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- This file implements 'singletonStar', which generates a datatype @Rep@ and associated +-- singleton from a list of types. The promoted version of @Rep@ is kind @*@ and the +-- Haskell types themselves. This is still very experimental, so expect unusual +-- results! +-- +---------------------------------------------------------------------------- + +module Data.Singletons.CustomStar ( singletonStar ) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax ( Quasi(..) ) +import Data.Singletons.Util +import Data.Singletons.Promote +import Data.Singletons.Singletons +import Control.Monad + +#if __GLASGOW_HASKELL__ >= 707 +import Data.Singletons.Decide +import Data.Singletons.Instances +import Data.Singletons.Eq +import Unsafe.Coerce +#endif + +{- +The SEq instance here is tricky. +The problem is that, in GHC 7.8+, the instance of type-level (==) for * +is not recursive. Thus, it's impossible, say, to get (Maybe a == Maybe b) ~ False +from (a == b) ~ False. + +There are a few ways forward: + 1) Define SEq to use our own Boolean (==) operator, instead of the built-in one. + This would work, but feels wrong. + 2) Use unsafeCoerce. +We do #2. + +Also to note: because these problems don't exist in GHC 7.6, the generation of +Eq and Decide for 7.6 is entirely normal. + +Note that mkCustomEqInstances makes the SDecide and SEq instances in GHC 7.8+, +but the type-level (==) instance in GHC 7.6. This is perhaps poor design, but +it reduces the amount of CPP noise. +-} + +-- | Produce a representation and singleton for the collection of types given. +-- +-- A datatype @Rep@ is created, with one constructor per type in the declared +-- universe. When this type is promoted by the singletons library, the +-- constructors become full types in @*@, not just promoted data constructors. +-- +-- For example, +-- +-- > $(singletonStar [''Nat, ''Bool, ''Maybe]) +-- +-- generates the following: +-- +-- > data Rep = Nat | Bool | Maybe Rep deriving (Eq, Show, Read) +-- +-- and its singleton. However, because @Rep@ is promoted to @*@, the singleton +-- is perhaps slightly unexpected: +-- +-- > data instance Sing (a :: *) where +-- > SNat :: Sing Nat +-- > SBool :: Sing Bool +-- > SMaybe :: SingRep a => Sing a -> Sing (Maybe a) +-- +-- The unexpected part is that @Nat@, @Bool@, and @Maybe@ above are the real @Nat@, +-- @Bool@, and @Maybe@, not just promoted data constructors. +-- +-- Please note that this function is /very/ experimental. Use at your own risk. +singletonStar :: Quasi q + => [Name] -- ^ A list of Template Haskell @Name@s for types + -> q [Dec] +singletonStar names = do + kinds <- mapM getKind names + ctors <- zipWithM (mkCtor True) names kinds + let repDecl = DataD [] repName [] ctors + [''Eq, ''Show, ''Read] + fakeCtors <- zipWithM (mkCtor False) names kinds + eqInstances <- mkCustomEqInstances fakeCtors + singletonDecls <- singDataD True [] repName [] fakeCtors + [''Show, ''Read +#if __GLASGOW_HASKELL__ < 707 + , ''Eq +#endif + ] + return $ repDecl : + eqInstances ++ + singletonDecls + where -- get the kinds of the arguments to the tycon with the given name + getKind :: Quasi q => Name -> q [Kind] + getKind name = do + info <- reifyWithWarning name + case info of + TyConI (DataD (_:_) _ _ _ _) -> + fail "Cannot make a representation of a constrainted data type" + TyConI (DataD [] _ tvbs _ _) -> + return $ map extractTvbKind tvbs + TyConI (NewtypeD (_:_) _ _ _ _) -> + fail "Cannot make a representation of a constrainted newtype" + TyConI (NewtypeD [] _ tvbs _ _) -> + return $ map extractTvbKind tvbs + TyConI (TySynD _ tvbs _) -> + return $ map extractTvbKind tvbs + PrimTyConI _ n _ -> + return $ replicate n StarT + _ -> fail $ "Invalid thing for representation: " ++ (show name) + + -- first parameter is whether this is a real ctor (with a fresh name) + -- or a fake ctor (when the name is actually a Haskell type) + mkCtor :: Quasi q => Bool -> Name -> [Kind] -> q Con + mkCtor real name args = do + (types, vars) <- evalForPair $ mapM kindToType args + let ctor = NormalC ((if real then reinterpret else id) name) + (map (\ty -> (NotStrict, ty)) types) + if length vars > 0 + then return $ ForallC (map PlainTV vars) [] ctor + else return ctor + + -- demote a kind back to a type, accumulating any unbound parameters + kindToType :: Quasi q => Kind -> QWithAux [Name] q Type + kindToType (ForallT _ _ _) = fail "Explicit forall encountered in kind" + kindToType (AppT k1 k2) = do + t1 <- kindToType k1 + t2 <- kindToType k2 + return $ AppT t1 t2 + kindToType (SigT _ _) = fail "Sort signature encountered in kind" + kindToType (VarT n) = do + addElement n + return $ VarT n + kindToType (ConT n) = return $ ConT n + kindToType (PromotedT _) = fail "Promoted type used as a kind" + kindToType (TupleT n) = return $ TupleT n + kindToType (UnboxedTupleT _) = fail "Unboxed tuple kind encountered" + kindToType ArrowT = return ArrowT + kindToType ListT = return ListT + kindToType (PromotedTupleT _) = fail "Promoted tuple kind encountered" + kindToType PromotedNilT = fail "Promoted nil kind encountered" + kindToType PromotedConsT = fail "Promoted cons kind encountered" + kindToType StarT = return $ ConT repName + kindToType ConstraintT = + fail $ "Cannot make a representation of a type that has " ++ + "an argument of kind Constraint" + kindToType (LitT _) = fail "Literal encountered at the kind level" + +mkCustomEqInstances :: Quasi q => [Con] -> q [Dec] +mkCustomEqInstances ctors = do +#if __GLASGOW_HASKELL__ >= 707 + let ctorVar = error "Internal error: Equality instance inspected ctor var" + sCtors <- evalWithoutAux $ mapM (singCtor ctorVar) ctors + decideInst <- mkEqualityInstance StarT sCtors sDecideClassDesc + + a <- qNewName "a" + b <- qNewName "b" + let eqInst = InstanceD + [] + (AppT (ConT ''SEq) (kindParam StarT)) + [FunD '(%:==) + [Clause [VarP a, VarP b] + (NormalB $ + CaseE (foldExp (VarE '(%~)) [VarE a, VarE b]) + [ Match (ConP 'Proved [ConP 'Refl []]) + (NormalB $ ConE 'STrue) [] + , Match (ConP 'Disproved [WildP]) + (NormalB $ AppE (VarE 'unsafeCoerce) + (ConE 'SFalse)) [] + ]) []]] + return [decideInst, eqInst] +#else + mapM mkEqTypeInstance [(c1, c2) | c1 <- ctors, c2 <- ctors] +#endif diff --git a/src/Data/Singletons/Decide.hs b/src/Data/Singletons/Decide.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Decide.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP, RankNTypes, PolyKinds, DataKinds, TypeOperators, + TypeFamilies, FlexibleContexts, UndecidableInstances, GADTs #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.Decide +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines the class 'SDecide', allowing for decidable equality over singletons. +-- +---------------------------------------------------------------------------- + +module Data.Singletons.Decide ( + -- * The SDecide class + SDecide(..), + + -- * Supporting definitions + (:~:)(..), Void, Refuted, Decision(..) + ) where + +import Data.Singletons +import Data.Singletons.Types +import Data.Singletons.Void + +---------------------------------------------------------------------- +---- SDecide --------------------------------------------------------- +---------------------------------------------------------------------- + +-- | Because we can never create a value of type 'Void', a function that type-checks +-- at @a -> Void@ shows that objects of type @a@ can never exist. Thus, we say that +-- @a@ is 'Refuted' +type Refuted a = (a -> Void) + +-- | A 'Decision' about a type @a@ is either a proof of existence or a proof that @a@ +-- cannot exist. +data Decision a = Proved a -- ^ Witness for @a@ + | Disproved (Refuted a) -- ^ Proof that no @a@ exists + +-- | Members of the 'SDecide' "kind" class support decidable equality. Instances +-- of this class are generated alongside singleton definitions for datatypes that +-- derive an 'Eq' instance. +class (kparam ~ 'KProxy) => SDecide (kparam :: KProxy k) where + -- | Compute a proof or disproof of equality, given two singletons. + (%~) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Decision (a :~: b) + +instance SDecide ('KProxy :: KProxy k) => TestEquality (Sing :: k -> *) where + testEquality a b = + case a %~ b of + Proved Refl -> Just Refl + Disproved _ -> Nothing diff --git a/src/Data/Singletons/Either.hs b/src/Data/Singletons/Either.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Either.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, GADTs, + DataKinds, PolyKinds, RankNTypes, UndecidableInstances, CPP #-} + +#if __GLASGOW_HASKELL__ < 707 +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.Either +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines functions and datatypes relating to the singleton for 'Either', +-- including a singletons version of all the definitions in @Data.Either@. +-- +-- Because many of these definitions are produced by Template Haskell, +-- it is not possible to create proper Haddock documentation. Please look +-- up the corresponding operation in @Data.Either@. Also, please excuse +-- the apparent repeated variable names. This is due to an interaction +-- between Template Haskell and Haddock. +-- +---------------------------------------------------------------------------- + +module Data.Singletons.Either ( + -- * The 'Either' singleton + Sing(SLeft, SRight), + -- | Though Haddock doesn't show it, the 'Sing' instance above declares + -- constructors + -- + -- > SLeft :: Sing a -> Sing (Left a) + -- > SRight :: Sing b -> Sing (Right b) + + SEither, + -- | 'SEither' is a kind-restricted synonym for 'Sing': + -- @type SEither (a :: Either x y) = Sing a@ + + -- * Singletons from @Data.Either@ + Either_, sEither_, + -- | The preceding two definitions are derived from the function 'either' in + -- @Data.Either@. The extra underscore is to avoid name clashes with the type + -- 'Either'. + + Lefts, sLefts, Rights, sRights, + PartitionEithers, sPartitionEithers, IsLeft, sIsLeft, IsRight, sIsRight + ) where + +import Data.Singletons.Instances +import Data.Singletons.TH +import Data.Singletons.List + +$(singletonsOnly [d| + -- | Case analysis for the 'Either' type. + -- If the value is @'Left' a@, apply the first function to @a@; + -- if it is @'Right' b@, apply the second function to @b@. + either_ :: (a -> c) -> (b -> c) -> Either a b -> c + either_ f _ (Left x) = f x + either_ _ g (Right y) = g y + + -- | Extracts from a list of 'Either' all the 'Left' elements + -- All the 'Left' elements are extracted in order. + + lefts :: [Either a b] -> [a] + lefts [] = [] + lefts (Left x : xs) = x : lefts xs + lefts (Right _ : xs) = lefts xs + + -- | Extracts from a list of 'Either' all the 'Right' elements + -- All the 'Right' elements are extracted in order. + + rights :: [Either a b] -> [b] + rights [] = [] + rights (Left _ : xs) = rights xs + rights (Right x : xs) = x : rights xs + + -- | Partitions a list of 'Either' into two lists + -- All the 'Left' elements are extracted, in order, to the first + -- component of the output. Similarly the 'Right' elements are extracted + -- to the second component of the output. + + partitionEithers :: [Either a b] -> ([a],[b]) + partitionEithers es = partitionEithers_aux ([], []) es + + partitionEithers_aux :: ([a],[b]) -> [Either a b] -> ([a],[b]) + partitionEithers_aux (as,bs) [] = (reverse as,reverse bs) + partitionEithers_aux (as,bs) (Left a : es) = + partitionEithers_aux (a : as, bs) es + partitionEithers_aux (as,bs) (Right b : es) = + partitionEithers_aux (as, b : bs) es + + -- | Return `True` if the given value is a `Left`-value, `False` otherwise. + -- + -- /Since: 4.7.0.0/ + isLeft :: Either a b -> Bool + isLeft (Left _) = True + isLeft (Right _) = False + + -- | Return `True` if the given value is a `Right`-value, `False` otherwise. + -- + -- /Since: 4.7.0.0/ + isRight :: Either a b -> Bool + isRight (Left _) = False + isRight (Right _) = True + |]) diff --git a/src/Data/Singletons/Eq.hs b/src/Data/Singletons/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Eq.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, + RankNTypes, FlexibleContexts, TemplateHaskell, + UndecidableInstances, GADTs, CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.Eq +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines the SEq singleton version of the Eq type class. +-- +----------------------------------------------------------------------------- + +module Data.Singletons.Eq ( + SEq(..), + type (==), (:==), (:/=) + ) where + +import Data.Singletons.Util +import Data.Singletons.Bool +import Data.Singletons +import Data.Singletons.Singletons +import Data.Singletons.Instances +import Data.Singletons.Types +#if __GLASGOW_HASKELL__ < 707 +import Data.Singletons.Promote ( promoteEqInstances ) +#endif + +-- | A type synonym conforming to singletons naming conventions +type a :/= b = Not (a :== b) + +-- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is required +-- that instances define a body for '(%:==)'. You may also supply a body for '(%:/=)'. +class (kparam ~ 'KProxy) => SEq (kparam :: KProxy k) where + -- | Boolean equality on singletons + (%:==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :== b) + + -- | Boolean disequality on singletons + (%:/=) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/= b) + a %:/= b = sNot (a %:== b) + + +#if __GLASGOW_HASKELL__ < 707 +$(promoteEqInstances basicTypes) -- these instances are in Data.Type.Equality +#endif + +$(singEqInstancesOnly basicTypes) diff --git a/src/Data/Singletons/Instances.hs b/src/Data/Singletons/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Instances.hs @@ -0,0 +1,29 @@ +{- Data/Singletons/Instances.hs + +(c) Richard Eisenberg 2013 +eir@cis.upenn.edu + +This (internal) module contains the main class definitions for singletons, +re-exported from various places. + +-} + +{-# LANGUAGE CPP, RankNTypes, DataKinds, PolyKinds, GADTs, TypeFamilies, + FlexibleContexts, TemplateHaskell, ScopedTypeVariables, + UndecidableInstances, TypeOperators, FlexibleInstances #-} +#if __GLASGOW_HASKELL__ < 707 + -- optimizing instances of SDecide cause GHC to die (#8467) +{-# OPTIONS_GHC -O0 #-} +#endif + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Singletons.Instances where + +import Data.Singletons.Singletons +import Data.Singletons.Util + +-- some useful singletons +$(genSingletons basicTypes) +$(singDecideInstances basicTypes) + diff --git a/src/Data/Singletons/List.hs b/src/Data/Singletons/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/List.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE CPP, TypeOperators, DataKinds, PolyKinds, TypeFamilies, + TemplateHaskell, GADTs, UndecidableInstances #-} + +#if __GLASGOW_HASKELL__ < 707 +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.List +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines functions and datatypes relating to the singleton for '[]', +-- including a singletons version of a few of the definitions in @Data.List@. +-- +-- Because many of these definitions are produced by Template Haskell, +-- it is not possible to create proper Haddock documentation. Please look +-- up the corresponding operation in @Data.List@. Also, please excuse +-- the apparent repeated variable names. This is due to an interaction +-- between Template Haskell and Haddock. +-- +---------------------------------------------------------------------------- + +module Data.Singletons.List ( + -- * The singleton for lists + Sing(SNil, SCons), + -- | Though Haddock doesn't show it, the 'Sing' instance above declares + -- constructors + -- + -- > SNil :: Sing '[] + -- > SCons :: Sing (h :: k) -> Sing (t :: [k]) -> Sing (h ': t) + + SList, + -- | 'SList' is a kind-restricted synonym for 'Sing': @type SList (a :: [k]) = Sing a@ + + Head, Tail, sHead, sTail, + (:++), (%:++), + Reverse, sReverse + ) where + +import Data.Singletons.Instances +import Data.Singletons +import Data.Singletons.Singletons +import Data.Singletons.TypeLits + +$(singletonsOnly [d| + (++) :: [a] -> [a] -> [a] + [] ++ a = a + (h:t) ++ a = h:(t ++ a) + + head :: [a] -> a + head (a : _) = a + head [] = error "Data.Singletons.List.head: empty list" + + tail :: [a] -> [a] + tail (_ : t) = t + tail [] = error "Data.Singletons.List.tail: empty list" + + reverse :: [a] -> [a] + reverse list = reverse_aux [] list + + reverse_aux :: [a] -> [a] -> [a] + reverse_aux acc [] = acc + reverse_aux acc (h : t) = reverse_aux (h : acc) t + |]) diff --git a/src/Data/Singletons/Maybe.hs b/src/Data/Singletons/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Maybe.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, + DataKinds, PolyKinds, UndecidableInstances, GADTs, + RankNTypes, CPP #-} + +#if __GLASGOW_HASKELL__ < 707 +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.Maybe +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines functions and datatypes relating to the singleton for 'Maybe', +-- including a singletons version of all the definitions in @Data.Maybe@. +-- +-- Because many of these definitions are produced by Template Haskell, +-- it is not possible to create proper Haddock documentation. Please look +-- up the corresponding operation in @Data.Maybe@. Also, please excuse +-- the apparent repeated variable names. This is due to an interaction +-- between Template Haskell and Haddock. +-- +---------------------------------------------------------------------------- + + +module Data.Singletons.Maybe ( + -- The 'Maybe' singleton + + Sing(SNothing, SJust), + -- | Though Haddock doesn't show it, the 'Sing' instance above declares + -- constructors + -- + -- > SNothing :: Sing Nothing + -- > SJust :: Sing a -> Sing (Just a) + + SMaybe, + -- | 'SBool' is a kind-restricted synonym for 'Sing': @type SMaybe (a :: Maybe k) = Sing a@ + + -- * Singletons from @Data.Maybe@ + + Maybe_, sMaybe_, + -- | The preceding two definitions are derived from the function 'maybe' in + -- @Data.Maybe@. The extra underscore is to avoid name clashes with the type + -- 'Maybe'. + + IsJust, sIsJust, IsNothing, sIsNothing, + FromJust, sFromJust, FromMaybe, sFromMaybe, MaybeToList, sMaybeToList, + ListToMaybe, sListToMaybe, CatMaybes, sCatMaybes, MapMaybe, sMapMaybe + ) where + +import Data.Singletons.Instances +import Data.Singletons +import Data.Singletons.TH +import Data.Singletons.List +import Data.Singletons.TypeLits + +$(singletonsOnly [d| + -- | The 'maybe' function takes a default value, a function, and a 'Maybe' + -- value. If the 'Maybe' value is 'Nothing', the function returns the + -- default value. Otherwise, it applies the function to the value inside + -- the 'Just' and returns the result. + maybe_ :: b -> (a -> b) -> Maybe a -> b + maybe_ n _ Nothing = n + maybe_ _ f (Just x) = f x + + -- | The 'isJust' function returns 'True' iff its argument is of the + -- form @Just _@. + isJust :: Maybe a -> Bool + isJust Nothing = False + isJust (Just _) = True + + -- | The 'isNothing' function returns 'True' iff its argument is 'Nothing'. + isNothing :: Maybe a -> Bool + isNothing Nothing = True + isNothing (Just _) = False + + -- | The 'fromJust' function extracts the element out of a 'Just' and + -- throws an error if its argument is 'Nothing'. + fromJust :: Maybe a -> a + fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck + fromJust (Just x) = x + + -- | The 'fromMaybe' function takes a default value and and 'Maybe' + -- value. If the 'Maybe' is 'Nothing', it returns the default values; + -- otherwise, it returns the value contained in the 'Maybe'. + fromMaybe :: a -> Maybe a -> a + fromMaybe d Nothing = d + fromMaybe _ (Just v) = v + + -- | The 'maybeToList' function returns an empty list when given + -- 'Nothing' or a singleton list when not given 'Nothing'. + maybeToList :: Maybe a -> [a] + maybeToList Nothing = [] + maybeToList (Just x) = [x] + + -- | The 'listToMaybe' function returns 'Nothing' on an empty list + -- or @'Just' a@ where @a@ is the first element of the list. + listToMaybe :: [a] -> Maybe a + listToMaybe [] = Nothing + listToMaybe (a:_) = Just a + + -- | The 'catMaybes' function takes a list of 'Maybe's and returns + -- a list of all the 'Just' values. + catMaybes :: [Maybe a] -> [a] + catMaybes [] = [] + catMaybes (Just x : xs) = x : catMaybes xs + catMaybes (Nothing : xs) = catMaybes xs + + -- | The 'mapMaybe' function is a version of 'map' which can throw + -- out elements. In particular, the functional argument returns + -- something of type @'Maybe' b@. If this is 'Nothing', no element + -- is added on to the result list. If it just @'Just' b@, then @b@ is + -- included in the result list. + mapMaybe :: (a -> Maybe b) -> [a] -> [b] + mapMaybe _ [] = [] + mapMaybe f (x:xs) = maybeToList (f x) ++ (mapMaybe f xs) + |]) diff --git a/src/Data/Singletons/Prelude.hs b/src/Data/Singletons/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Prelude.hs @@ -0,0 +1,106 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.Prelude +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- Mimics the Haskell Prelude, but with singleton types. Includes the basic +-- singleton definitions. Note: This is currently very incomplete! +-- +-- Because many of these definitions are produced by Template Haskell, it is +-- not possible to create proper Haddock documentation. Also, please excuse +-- the apparent repeated variable names. This is due to an interaction between +-- Template Haskell and Haddock. +-- +---------------------------------------------------------------------------- + +module Data.Singletons.Prelude ( + -- * Basic singleton definitions + module Data.Singletons, + + Sing(SFalse, STrue, SNil, SCons, SJust, SNothing, SLeft, SRight, SLT, SEQ, SGT, + STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7), + -- | Though Haddock doesn't show it, the 'Sing' instance above includes + -- the following instances + -- + -- > data instance Sing (a :: Bool) where + -- > SFalse :: Sing False + -- > STrue :: Sing True + -- > + -- > data instance Sing (a :: [k]) where + -- > SNil :: Sing '[] + -- > SCons :: Sing (h :: k) -> Sing (t :: [k]) -> Sing (h ': t) + -- > + -- > data instance Sing (a :: Maybe k) where + -- > SNothing :: Sing Nothing + -- > SJust :: Sing (a :: k) -> Sing (Just a) + -- > + -- > data instance Sing (a :: Either x y) where + -- > SLeft :: Sing (a :: x) -> Sing (Left a) + -- > SRight :: Sing (b :: y) -> Sing (Right b) + -- > + -- > data instance Sing (a :: Ordering) where + -- > SLT :: Sing LT + -- > SEQ :: Sing EQ + -- > SGT :: Sing GT + -- > + -- > data instance Sing (a :: ()) where + -- > STuple0 :: Sing '() + -- > + -- > data instance Sing (z :: (a, b)) where + -- > STuple2 :: Sing a -> Sing b -> Sing '(a, b) + -- > + -- > data instance Sing (z :: (a, b, c)) where + -- > STuple3 :: Sing a -> Sing b -> Sing c -> Sing '(a, b, c) + -- > + -- > data instance Sing (z :: (a, b, c, d)) where + -- > STuple4 :: Sing a -> Sing b -> Sing c -> Sing d -> Sing '(a, b, c, d) + -- > + -- > data instance Sing (z :: (a, b, c, d, e)) where + -- > STuple5 :: Sing a -> Sing b -> Sing c -> Sing d -> Sing e -> Sing '(a, b, c, d, e) + -- > + -- > data instance Sing (z :: (a, b, c, d, e, f)) where + -- > STuple6 :: Sing a -> Sing b -> Sing c -> Sing d -> Sing e -> Sing f + -- > -> Sing '(a, b, c, d, e, f) + -- > + -- > data instance Sing (z :: (a, b, c, d, e, f, g)) where + -- > STuple7 :: Sing a -> Sing b -> Sing c -> Sing d -> Sing e -> Sing f + -- > -> Sing g -> Sing '(a, b, c, d, e, f, g) + + -- * Singleton type synonyms + + -- | These synonyms are all kind-restricted synonyms of 'Sing'. + -- For example 'SBool' requires an argument of kind 'Bool'. + SBool, SList, SMaybe, SEither, SOrdering, + STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7, + + -- * Functions working with 'Bool' + If, sIf, Not, sNot, (:&&), (:||), (%:&&), (%:||), + + -- * Functions working with lists + Head, Tail, (:++), (%:++), + + -- * Error reporting + Error, sError, + + -- * Singleton equality + module Data.Singletons.Eq, + + -- * Other datatypes + Maybe_, sMaybe_, + Either_, sEither_, + Fst, sFst, Snd, sSnd, Curry, sCurry, Uncurry, sUncurry + ) where + +import Data.Singletons +import Data.Singletons.Bool +import Data.Singletons.List +import Data.Singletons.Maybe +import Data.Singletons.Either +import Data.Singletons.Tuple +import Data.Singletons.Eq +import Data.Singletons.Instances +import Data.Singletons.TypeLits diff --git a/src/Data/Singletons/Promote.hs b/src/Data/Singletons/Promote.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Promote.hs @@ -0,0 +1,699 @@ +{- Data/Singletons/Promote.hs + +(c) Richard Eisenberg 2013 +eir@cis.upenn.edu + +This file contains functions to promote term-level constructs to the +type level. It is an internal module to the singletons package. +-} + +{-# LANGUAGE TemplateHaskell, CPP #-} + +module Data.Singletons.Promote where + +import Language.Haskell.TH hiding ( Q, cxt ) +import Language.Haskell.TH.Syntax ( falseName, trueName, Quasi(..) ) +import Data.Singletons.Util +import Data.Singletons.Types +import GHC.Exts (Any) +import GHC.TypeLits (Symbol) +import Prelude hiding (exp) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Monad +import Data.List + +anyTypeName, boolName, andName, tyEqName, repName, ifName, + headName, tailName, symbolName :: Name +anyTypeName = ''Any +boolName = ''Bool +andName = '(&&) +#if __GLASGOW_HASKELL__ >= 707 +tyEqName = ''(==) +#else +tyEqName = ''(:==) +#endif +repName = mkName "Rep" +ifName = ''If +headName = mkName "Head" -- these will go away with the th-desugar change +tailName = mkName "Tail" +symbolName = ''Symbol + +falseTy :: Type +falseTy = PromotedT falseName + +trueTy :: Type +trueTy = PromotedT trueName + +boolTy :: Type +boolTy = ConT boolName + +andTy :: Type +andTy = promoteVal andName + +ifTyFam :: Type +ifTyFam = ConT ifName + +headTyFam :: Type +headTyFam = ConT headName + +tailTyFam :: Type +tailTyFam = ConT tailName + +promoteInfo :: Quasi q => Info -> q [Dec] +promoteInfo (ClassI _dec _instances) = + fail "Promotion of class info not supported" +promoteInfo (ClassOpI _name _ty _className _fixity) = + fail "Promotion of class members info not supported" +promoteInfo (TyConI dec) = evalWithoutAux $ promoteDec Map.empty dec +promoteInfo (FamilyI _dec _instances) = + fail "Promotion of type family info not yet supported" -- KindFams +promoteInfo (PrimTyConI _name _numArgs _unlifted) = + fail "Promotion of primitive type constructors not supported" +promoteInfo (DataConI _name _ty _tyname _fixity) = + fail $ "Promotion of individual constructors not supported; " ++ + "promote the type instead" +promoteInfo (VarI _name _ty _mdec _fixity) = + fail "Promotion of value info not supported" +promoteInfo (TyVarI _name _ty) = + fail "Promotion of type variable info not supported" + +promoteValName :: Name -> Name +promoteValName n + | nameBase n == "undefined" = anyTypeName + | otherwise = upcase n + +promoteVal :: Name -> Type +promoteVal = ConT . promoteValName + +promoteType :: Quasi q => Type -> q Kind +-- We don't need to worry about constraints: they are used to express +-- static guarantees at runtime. But, because we don't need to do +-- anything special to keep static guarantees at compile time, we don't +-- need to promote them. +promoteType (ForallT _tvbs _ ty) = promoteType ty -- ForallKinds +promoteType (VarT name) = return $ VarT name +promoteType (ConT name) = return $ + case nameBase name of + "TypeRep" -> StarT + "String" -> ConT symbolName + x | x == nameBase repName -> StarT + | otherwise -> ConT name +promoteType (TupleT n) = return $ TupleT n +promoteType (UnboxedTupleT _n) = fail "Promotion of unboxed tuples not supported" +promoteType ArrowT = return ArrowT +promoteType ListT = return ListT +promoteType (AppT (AppT ArrowT (ForallT (_:_) _ _)) _) = + fail "Cannot promote types of rank above 1." +promoteType (AppT ty1 ty2) = do + k1 <- promoteType ty1 + k2 <- promoteType ty2 + return $ AppT k1 k2 +promoteType (SigT _ty _) = fail "Cannot promote type of kind other than *" +promoteType (LitT _) = fail "Cannot promote a type-level literal" +promoteType (PromotedT _) = fail "Cannot promote a promoted data constructor" +promoteType (PromotedTupleT _) = fail "Cannot promote tuples that are already promoted" +promoteType PromotedNilT = fail "Cannot promote a nil that is already promoted" +promoteType PromotedConsT = fail "Cannot promote a cons that is already promoted" +promoteType StarT = fail "* used as a type" +promoteType ConstraintT = fail "Constraint used as a type" + +-- a table to keep track of variable->type mappings +type TypeTable = Map.Map Name Type + +-- | Promote every declaration given to the type level, retaining the originals. +promote :: Quasi q => q [Dec] -> q [Dec] +promote qdec = do + decls <- qdec + promDecls <- promoteDecs decls + return $ decls ++ promDecls + +-- | Promote each declaration, discarding the originals. +promoteOnly :: Quasi q => q [Dec] -> q [Dec] +promoteOnly qdec = do + decls <- qdec + promDecls <- promoteDecs decls + return promDecls + +checkForRep :: Quasi q => [Name] -> q () +checkForRep names = + when (any ((== nameBase repName) . nameBase) names) + (fail $ "A data type named <> is a special case.\n" ++ + "Promoting it will not work as expected.\n" ++ + "Please choose another name for your data type.") + +checkForRepInDecls :: Quasi q => [Dec] -> q () +checkForRepInDecls decls = + checkForRep (map extractNameFromDec decls) + where extractNameFromDec :: Dec -> Name + extractNameFromDec (DataD _ name _ _ _) = name + extractNameFromDec (NewtypeD _ name _ _ _) = name + extractNameFromDec (TySynD name _ _) = name + extractNameFromDec (FamilyD _ name _ _) = name + extractNameFromDec _ = mkName "NotRep" + +-- Note [Promoting declarations in two stages] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Promoting declarations proceeds in two stages: +-- 1) Promote everything except type signatures +-- 2) Promote type signatures. This must be done in a second pass +-- because a function type signature gets promoted to a type family +-- declaration. Although function signatures do not differentiate +-- between uniform parameters and non-uniform parameters, type +-- family declarations do. We need to process a function's +-- definition to get the count of non-uniform parameters before +-- producing the type family declaration. At this point, any +-- function written without a type signature is rejected and +-- removed. +-- +-- Consider this example: +-- +-- foo :: Int -> Bool -> Bool +-- foo 0 = id +-- foo _ = not +-- +-- Here the first parameter to foo is non-uniform, because it is +-- inspected in a pattern and can be different in each defining +-- equation of foo. The second parameter to foo, specified in the type +-- signature as Bool, is a uniform parameter - it is not inspected and +-- each defining equation of foo uses it the same way. The foo +-- function will be promoted to a type familty Foo like this: +-- +-- type family Foo (n :: Int) :: Bool -> Bool where +-- Foo 0 = Id +-- Foo a = Not +-- +-- To generate type signature for Foo type family we must first learn +-- what is the actual number of patterns used in defining cequations +-- of foo. In this case there is only one so we declare Foo to take +-- one argument and have return type of Bool -> Bool. + +-- Promote a list of declarations. +promoteDecs :: Quasi q => [Dec] -> q [Dec] +promoteDecs decls = do + checkForRepInDecls decls + let vartbl = Map.empty + -- See Note [Promoting declarations in two stages] + (newDecls, table) <- evalForPair $ mapM (promoteDec vartbl) decls + (declss, namess) <- mapAndUnzipM (promoteDec' table) decls + let moreNewDecls = concat declss + names = concat namess + noTypeSigs = Set.toList $ Set.difference (Map.keysSet $ +#if __GLASGOW_HASKELL__ >= 707 + Map.filter ((>= 0) . fst) table) +#else + Map.filter (>= 0) table) +#endif + (Set.fromList names) + when (not . null $ noTypeSigs) $ fail ("No type signature for functions: " + ++ intercalate ", " (map (show . nameBase) noTypeSigs) + ++ "; cannot promote or make singletons.") + return (concat newDecls ++ moreNewDecls) + +-- | Produce instances for '(:==)' (type-level equality) from the given types +promoteEqInstances :: Quasi q => [Name] -> q [Dec] +promoteEqInstances = concatMapM promoteEqInstance + +-- | Produce an instance for '(:==)' (type-level equality) from the given type +promoteEqInstance :: Quasi q => Name -> q [Dec] +promoteEqInstance name = do + (_tvbs, cons) <- getDataD "I cannot make an instance of (:==:) for it." name +#if __GLASGOW_HASKELL__ >= 707 + vars <- replicateM (length _tvbs) (qNewName "k") + let tyvars = map VarT vars + kind = foldType (ConT name) tyvars + inst_decs <- mkEqTypeInstance kind cons + return inst_decs +#else + let pairs = [(c1, c2) | c1 <- cons, c2 <- cons] + mapM mkEqTypeInstance pairs +#endif + +#if __GLASGOW_HASKELL__ >= 707 + +-- produce a closed type family helper and the instance +-- for (:==) over the given list of ctors +mkEqTypeInstance :: Quasi q => Kind -> [Con] -> q [Dec] +mkEqTypeInstance kind cons = do + helperName <- newUniqueName "Equals" + aName <- qNewName "a" + bName <- qNewName "b" + true_branches <- mapM mk_branch cons + false_branch <- false_case + let closedFam = ClosedTypeFamilyD helperName + [ KindedTV aName kind + , KindedTV bName kind ] + (Just boolTy) + (true_branches ++ [false_branch]) + eqInst = TySynInstD tyEqName (TySynEqn [ SigT (VarT aName) kind + , SigT (VarT bName) kind ] + (foldType (ConT helperName) + [VarT aName, VarT bName])) + return [closedFam, eqInst] + + where mk_branch :: Quasi q => Con -> q TySynEqn + mk_branch con = do + let (name, numArgs) = extractNameArgs con + lnames <- replicateM numArgs (qNewName "a") + rnames <- replicateM numArgs (qNewName "b") + let lvars = map VarT lnames + rvars = map VarT rnames + ltype = foldType (PromotedT name) lvars + rtype = foldType (PromotedT name) rvars + results = zipWith (\l r -> foldType (ConT tyEqName) [l, r]) lvars rvars + result = tyAll results + return $ TySynEqn [ltype, rtype] result + + false_case :: Quasi q => q TySynEqn + false_case = do + lvar <- qNewName "a" + rvar <- qNewName "b" + return $ TySynEqn [SigT (VarT lvar) kind, SigT (VarT rvar) kind] falseTy + + tyAll :: [Type] -> Type -- "all" at the type level + tyAll [] = trueTy + tyAll [one] = one + tyAll (h:t) = foldType andTy [h, (tyAll t)] + +#else + +-- produce the type instance for (:==) for the given pair of constructors +mkEqTypeInstance :: Quasi q => (Con, Con) -> q Dec +mkEqTypeInstance (c1, c2) = + if c1 == c2 + then do + let (name, numArgs) = extractNameArgs c1 + lnames <- replicateM numArgs (qNewName "a") + rnames <- replicateM numArgs (qNewName "b") + let lvars = map VarT lnames + rvars = map VarT rnames + return $ TySynInstD + tyEqName + [foldType (PromotedT name) lvars, + foldType (PromotedT name) rvars] + (tyAll (zipWith (\l r -> foldType (ConT tyEqName) [l, r]) + lvars rvars)) + else do + let (lname, lNumArgs) = extractNameArgs c1 + (rname, rNumArgs) = extractNameArgs c2 + lnames <- replicateM lNumArgs (qNewName "a") + rnames <- replicateM rNumArgs (qNewName "b") + return $ TySynInstD + tyEqName + [foldType (PromotedT lname) (map VarT lnames), + foldType (PromotedT rname) (map VarT rnames)] + falseTy + where tyAll :: [Type] -> Type -- "all" at the type level + tyAll [] = trueTy + tyAll [one] = one + tyAll (h:t) = foldType andTy [h, (tyAll t)] + +#endif + +-- keeps track of the number of non-uniform parameters to promoted values +-- and all of the instance equations for those values +#if __GLASGOW_HASKELL__ >= 707 +type PromoteTable = Map.Map Name (Int, [TySynEqn]) +#else +type PromoteTable = Map.Map Name Int +#endif +type PromoteQ q = QWithAux PromoteTable q + +-- used when a type is declared as a type synonym, not a type family +-- no need to declare "type family ..." for these +typeSynonymFlag :: Int +typeSynonymFlag = -1 + +promoteDec :: Quasi q => TypeTable -> Dec -> PromoteQ q [Dec] +promoteDec vars (FunD name clauses) = do + let proName = promoteValName name + vars' = Map.insert name (promoteVal name) vars + numArgs = getNumPats (head clauses) -- count the parameters + -- Haskell requires all clauses to have the same number of parameters + (eqns, instDecls) <- evalForPair $ + mapM (promoteClause vars' proName) clauses +#if __GLASGOW_HASKELL__ >= 707 + addBinding name (numArgs, eqns) -- remember the number of parameters and the eqns + return instDecls +#else + addBinding name numArgs -- remember the number of parameters + return $ eqns ++ instDecls +#endif + where getNumPats :: Clause -> Int + getNumPats (Clause pats _ _) = length pats +promoteDec vars (ValD pat body decs) = do + -- see also the comment for promoteTopLevelPat + when (length decs > 0) + (fail $ "Promotion of global variable with <> clause " ++ + "not yet supported") + (rhs, decls) <- evalForPair $ promoteBody vars body + (lhss, decls') <- evalForPair $ promoteTopLevelPat pat + -- just use "type" decls +#if __GLASGOW_HASKELL__ >= 707 + mapM_ (flip addBinding (typeSynonymFlag, [])) (map lhsRawName lhss) +#else + mapM_ (flip addBinding typeSynonymFlag) (map lhsRawName lhss) +#endif + return $ (map (\(LHS _ nm hole) -> TySynD nm [] (hole rhs)) lhss) ++ + decls ++ decls' +promoteDec vars (DataD cxt name tvbs ctors derivings) = + promoteDataD vars cxt name tvbs ctors derivings +promoteDec vars (NewtypeD cxt name tvbs ctor derivings) = + promoteDataD vars cxt name tvbs [ctor] derivings +promoteDec _vars (TySynD _name _tvbs _ty) = + fail "Promotion of type synonym declaration not yet supported" +promoteDec _vars (ClassD _cxt _name _tvbs _fundeps _decs) = + fail "Promotion of class declaration not yet supported" +promoteDec _vars (InstanceD _cxt _ty _decs) = + fail "Promotion of instance declaration not yet supported" +promoteDec _vars (SigD _name _ty) = return [] -- handle in promoteDec' +promoteDec _vars (ForeignD _fgn) = + fail "Promotion of foreign function declaration not yet supported" +promoteDec _vars (InfixD fixity name) + | isUpcase name = return [] -- automatic: promoting a type or data ctor + | otherwise = return [InfixD fixity (promoteValName name)] -- value +promoteDec _vars (PragmaD _prag) = + fail "Promotion of pragmas not yet supported" +promoteDec _vars (FamilyD _flavour _name _tvbs _mkind) = + fail "Promotion of type and data families not yet supported" +promoteDec _vars (DataInstD _cxt _name _tys _ctors _derivings) = + fail "Promotion of data instances not yet supported" +promoteDec _vars (NewtypeInstD _cxt _name _tys _ctors _derivings) = + fail "Promotion of newtype instances not yet supported" +#if __GLASGOW_HASKELL__ >= 707 +promoteDec _vars (RoleAnnotD _name _roles) = + return [] -- silently ignore role annotations, as they're harmless here +promoteDec _vars (ClosedTypeFamilyD _name _tvs _mkind _eqns) = + fail "Promotion of closed type families not yet supported" +promoteDec _vars (TySynInstD _name _eqn) = +#else +promoteDec _vars (TySynInstD _name _lhs _rhs) = +#endif + fail "Promotion of type synonym instances not yet supported" + +-- only need to check if the datatype derives Eq. The rest is automatic. +promoteDataD :: Quasi q => TypeTable -> Cxt -> Name -> [TyVarBndr] -> [Con] -> + [Name] -> PromoteQ q [Dec] +promoteDataD _vars _cxt _name _tvbs ctors derivings = + if any (\n -> (nameBase n) == "Eq") derivings + then do +#if __GLASGOW_HASKELL__ >= 707 + kvs <- replicateM (length _tvbs) (qNewName "k") + inst_decs <- mkEqTypeInstance (foldType (ConT _name) (map VarT kvs)) ctors + return inst_decs +#else + let pairs = [ (c1, c2) | c1 <- ctors, c2 <- ctors ] + mapM mkEqTypeInstance pairs +#endif + else return [] -- the actual promotion is automatic + +-- second pass through declarations to deal with type signatures +-- returns the new declarations and the list of names that have been +-- processed +promoteDec' :: Quasi q => PromoteTable -> Dec -> q ([Dec], [Name]) +promoteDec' tab (SigD name ty) = case Map.lookup name tab of + Nothing -> fail $ "Type declaration is missing its binding: " ++ (show name) +#if __GLASGOW_HASKELL__ >= 707 + Just (numArgs, eqns) -> +#else + Just numArgs -> +#endif + -- if there are no args, then use a type synonym, not a type family + -- in the type synonym case, we ignore the type signature + if numArgs == typeSynonymFlag then return $ ([], [name]) else do + k <- promoteType ty + let ks = unravel k + (argKs, resultKs) = splitAt numArgs ks -- divide by uniformity + resultK <- ravel resultKs -- rebuild the arrow kind + tyvarNames <- mapM qNewName (replicate (length argKs) "a") +#if __GLASGOW_HASKELL__ >= 707 + return ([ClosedTypeFamilyD (promoteValName name) + (zipWith KindedTV tyvarNames argKs) + (Just resultK) + eqns], [name]) +#else + return ([FamilyD TypeFam + (promoteValName name) + (zipWith KindedTV tyvarNames argKs) + (Just resultK)], [name]) +#endif + where unravel :: Kind -> [Kind] -- get argument kinds from an arrow kind + unravel (AppT (AppT ArrowT k1) k2) = + let ks = unravel k2 in k1 : ks + unravel k = [k] + + ravel :: Quasi q => [Kind] -> q Kind + ravel [] = fail "Internal error: raveling nil" + ravel [k] = return k + ravel (h:t) = do + k <- ravel t + return $ (AppT (AppT ArrowT h) k) +promoteDec' _ _ = return ([], []) + +#if __GLASGOW_HASKELL__ >= 707 +promoteClause :: Quasi q => TypeTable -> Name -> Clause -> QWithDecs q TySynEqn +#else +promoteClause :: Quasi q => TypeTable -> Name -> Clause -> QWithDecs q Dec +#endif +promoteClause vars _name (Clause pats body []) = do + -- promoting the patterns creates variable bindings. These are passed + -- to the function promoted the RHS + (types, vartbl) <- evalForPair $ mapM promotePat pats + let vars' = Map.union vars vartbl + ty <- promoteBody vars' body +#if __GLASGOW_HASKELL__ >= 707 + return $ TySynEqn types ty +#else + return $ TySynInstD _name types ty +#endif +promoteClause _ _ (Clause _ _ (_:_)) = + fail "A <> clause in a function definition is not yet supported" + +-- the LHS of a top-level expression is a name and "type with hole" +-- the hole is filled in by the RHS +data TopLevelLHS = LHS { lhsRawName :: Name -- the unpromoted name + , lhsName :: Name + , lhsHole :: Type -> Type + } + +-- Treatment of top-level patterns is different from other patterns +-- because type families have type patterns as their LHS. However, +-- it is not possible to use type patterns at the top level, so we +-- have to use other techniques. +promoteTopLevelPat :: Quasi q => Pat -> QWithDecs q [TopLevelLHS] +promoteTopLevelPat (LitP _) = fail "Cannot declare a global literal." +promoteTopLevelPat (VarP name) = return [LHS name (promoteValName name) id] +promoteTopLevelPat (TupP pats) = case length pats of + 0 -> return [] -- unit as LHS of pattern... ignore + 1 -> fail "1-tuple encountered during top-level pattern promotion" + n -> promoteTopLevelPat (ConP (tupleDataName n) pats) +promoteTopLevelPat (UnboxedTupP _) = + fail "Promotion of unboxed tuples not supported" + +-- to promote a constructor pattern, we need to create extraction type +-- families to pull out the individual arguments of the constructor +promoteTopLevelPat (ConP name pats) = do + ctorInfo <- reifyWithWarning name + (ctorType, argTypes) <- extractTypes ctorInfo + when (length argTypes /= length pats) $ + fail $ "Inconsistent data constructor pattern: " ++ (show name) ++ " " ++ + (show pats) + kind <- promoteType ctorType + argKinds <- mapM promoteType argTypes + extractorNames <- replicateM (length pats) (newUniqueName "Extract") + + varName <- qNewName "a" + zipWithM_ (\nm arg -> addElement $ FamilyD TypeFam + nm + [KindedTV varName kind] + (Just arg)) + extractorNames argKinds + componentNames <- replicateM (length pats) (qNewName "a") + zipWithM_ (\extractorName componentName -> + addElement $ mkTyFamInst extractorName + [foldType (PromotedT name) + (map VarT componentNames)] + (VarT componentName)) + extractorNames componentNames + + -- now we have the extractor families. Use the appropriate families + -- in the "holes" + promotedPats <- mapM promoteTopLevelPat pats + return $ concat $ + zipWith (\lhslist extractor -> + map (\(LHS raw nm hole) -> LHS raw nm + (hole . (AppT (ConT extractor)))) + lhslist) + promotedPats extractorNames + where extractTypes :: Quasi q => Info -> q (Type, [Type]) + extractTypes (DataConI datacon _dataconTy tyname _fixity) = do + tyinfo <- reifyWithWarning tyname + extractTypesHelper datacon tyinfo + extractTypes _ = fail "Internal error: unexpected Info in extractTypes" + + extractTypesHelper :: Quasi q => Name -> Info -> q (Type, [Type]) + extractTypesHelper datacon + (TyConI (DataD _cxt tyname tvbs cons _derivs)) = + let mcon = find ((== datacon) . fst . extractNameArgs) cons in + case mcon of + Nothing -> fail $ "Internal error reifying " ++ (show datacon) + Just con -> return (foldType (ConT tyname) + (map (VarT . extractTvbName) tvbs), + extractConArgs con) + extractTypesHelper datacon + (TyConI (NewtypeD cxt tyname tvbs con derivs)) = + extractTypesHelper datacon (TyConI (DataD cxt tyname tvbs [con] derivs)) + extractTypesHelper datacon _ = + fail $ "Cannot promote data constructor " ++ (show datacon) + + extractConArgs :: Con -> [Type] + extractConArgs = ctor1Case (\_ tys -> tys) +promoteTopLevelPat (InfixP l name r) = promoteTopLevelPat (ConP name [l, r]) +promoteTopLevelPat (UInfixP _ _ _) = + fail "Unresolved infix constructors not supported" +promoteTopLevelPat (ParensP _) = + fail "Unresolved infix constructors not supported" +promoteTopLevelPat (TildeP pat) = do + qReportWarning "Lazy pattern converted into regular pattern in promotion" + promoteTopLevelPat pat +promoteTopLevelPat (BangP pat) = do + qReportWarning "Strict pattern converted into regular pattern in promotion" + promoteTopLevelPat pat +promoteTopLevelPat (AsP _name _pat) = + fail "Promotion of aliased patterns at top level not yet supported" +promoteTopLevelPat WildP = return [] +promoteTopLevelPat (RecP _ _) = + fail "Promotion of record patterns at top level not yet supported" + +-- must do a similar trick as what is in the ConP case, but this is easier +-- because Lib defined Head and Tail +promoteTopLevelPat (ListP pats) = do + promotedPats <- mapM promoteTopLevelPat pats + return $ concat $ snd $ + mapAccumL (\extractFn lhss -> + ((AppT tailTyFam) . extractFn, + map (\(LHS raw nm hole) -> + LHS raw nm (hole . (AppT headTyFam) . extractFn)) lhss)) + id promotedPats +promoteTopLevelPat (SigP pat _) = do + qReportWarning $ "Promotion of explicit type annotation in pattern " ++ + "not yet supported." + promoteTopLevelPat pat +promoteTopLevelPat (ViewP _ _) = + fail "Promotion of view patterns not yet supported" + +type TypesQ q = QWithAux TypeTable q + +-- promotes a term pattern into a type pattern, accumulating variable +-- binding in the auxiliary TypeTable +promotePat :: Quasi q => Pat -> TypesQ q Type +promotePat (LitP lit) = promoteLit lit +promotePat (VarP name) = do + tyVar <- qNewName (nameBase name) + addBinding name (VarT tyVar) + return $ VarT tyVar +promotePat (TupP pats) = do + types <- mapM promotePat pats + let baseTup = PromotedTupleT (length types) + tup = foldType baseTup types + return tup +promotePat (UnboxedTupP _) = fail "Unboxed tuples not supported" +promotePat (ConP name pats) = do + types <- mapM promotePat pats + let tyCon = foldType (PromotedT name) types + return tyCon +promotePat (InfixP pat1 name pat2) = promotePat (ConP name [pat1, pat2]) +promotePat (UInfixP _ _ _) = fail "Unresolved infix constructions not supported" +promotePat (ParensP _) = fail "Unresolved infix constructions not supported" +promotePat (TildeP pat) = do + qReportWarning "Lazy pattern converted into regular pattern in promotion" + promotePat pat +promotePat (BangP pat) = do + qReportWarning "Strict pattern converted into regular pattern in promotion" + promotePat pat +promotePat (AsP name pat) = do + ty <- promotePat pat + addBinding name ty + return ty +promotePat WildP = do + name <- qNewName "z" + return $ VarT name +promotePat (RecP _ _) = fail "Promotion of record patterns not yet supported" +promotePat (ListP pats) = do + types <- mapM promotePat pats + return $ foldr (\h t -> AppT (AppT PromotedConsT h) t) PromotedNilT types +promotePat (SigP pat _) = do + qReportWarning $ "Promotion of explicit type annotation in pattern " ++ + "not yet supported" + promotePat pat +promotePat (ViewP _ _) = fail "View patterns not yet supported" + +-- promoting a body may produce auxiliary declarations. Accumulate these. +type QWithDecs q = QWithAux [Dec] q + +promoteBody :: Quasi q => TypeTable -> Body -> QWithDecs q Type +promoteBody vars (NormalB exp) = promoteExp vars exp +promoteBody _vars (GuardedB _) = + fail "Promoting guards in patterns not yet supported" + +promoteExp :: Quasi q => TypeTable -> Exp -> QWithDecs q Type +promoteExp vars (VarE name) = case Map.lookup name vars of + Just ty -> return ty + Nothing -> return $ promoteVal name +promoteExp _vars (ConE name) = return $ PromotedT name +promoteExp _vars (LitE lit) = promoteLit lit +promoteExp vars (AppE exp1 exp2) = do + ty1 <- promoteExp vars exp1 + ty2 <- promoteExp vars exp2 + return $ AppT ty1 ty2 +promoteExp vars (InfixE mexp1 exp mexp2) = + case (mexp1, mexp2) of + (Nothing, Nothing) -> promoteExp vars exp + (Just exp1, Nothing) -> promoteExp vars (AppE exp exp1) + (Nothing, Just _exp2) -> + fail "Promotion of right-only sections not yet supported" + (Just exp1, Just exp2) -> promoteExp vars (AppE (AppE exp exp1) exp2) +promoteExp _vars (UInfixE _ _ _) = + fail "Promotion of unresolved infix operators not supported" +promoteExp _vars (ParensE _) = fail "Promotion of unresolved parens not supported" +promoteExp _vars (LamE _pats _exp) = + fail "Promotion of lambda expressions not yet supported" +promoteExp _vars (LamCaseE _alts) = + fail "Promotion of lambda-case expressions not yet supported" +promoteExp vars (TupE exps) = do + tys <- mapM (promoteExp vars) exps + let tuple = PromotedTupleT (length tys) + tup = foldType tuple tys + return tup +promoteExp _vars (UnboxedTupE _) = fail "Promotion of unboxed tuples not supported" +promoteExp vars (CondE bexp texp fexp) = do + tys <- mapM (promoteExp vars) [bexp, texp, fexp] + return $ foldType ifTyFam tys +promoteExp _vars (MultiIfE _alts) = + fail "Promotion of multi-way if not yet supported" +promoteExp _vars (LetE _decs _exp) = + fail "Promotion of let statements not yet supported" +promoteExp _vars (CaseE _exp _matches) = + fail "Promotion of case statements not yet supported" +promoteExp _vars (DoE _stmts) = fail "Promotion of do statements not supported" +promoteExp _vars (CompE _stmts) = + fail "Promotion of list comprehensions not yet supported" +promoteExp _vars (ArithSeqE _) = fail "Promotion of ranges not supported" +promoteExp vars (ListE exps) = do + tys <- mapM (promoteExp vars) exps + return $ foldr (\ty lst -> AppT (AppT PromotedConsT ty) lst) PromotedNilT tys +promoteExp _vars (SigE _exp _ty) = + fail "Promotion of explicit type annotations not yet supported" +promoteExp _vars (RecConE _name _fields) = + fail "Promotion of record construction not yet supported" +promoteExp _vars (RecUpdE _exp _fields) = + fail "Promotion of record updates not yet supported" + +promoteLit :: Monad m => Lit -> m Type +promoteLit (IntegerL n) + | n >= 0 = return $ LitT (NumTyLit n) + | otherwise = fail ("Promoting negative integers not supported: " ++ (show n)) +promoteLit (StringL str) = return $ LitT (StrTyLit str) +promoteLit lit = + fail ("Only string and natural number literals can be promoted: " ++ show lit) diff --git a/src/Data/Singletons/Singletons.hs b/src/Data/Singletons/Singletons.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Singletons.hs @@ -0,0 +1,738 @@ +{- Data/Singletons/Singletons.hs + +(c) Richard Eisenberg 2013 +eir@cis.upenn.edu + +This file contains functions to refine constructs to work with singleton +types. It is an internal module to the singletons package. +-} +{-# LANGUAGE TemplateHaskell, CPP, TupleSections #-} + +module Data.Singletons.Singletons where + +import Prelude hiding ( exp ) +import Language.Haskell.TH hiding ( cxt ) +import Language.Haskell.TH.Syntax (falseName, trueName, Quasi(..)) +import Data.Singletons.Util +import Data.Singletons.Promote +import Data.Singletons +import Data.Singletons.Decide +import qualified Data.Map as Map +import Control.Monad +import Control.Applicative + +-- map to track bound variables +type ExpTable = Map.Map Name Exp + +-- translating a type gives a type with a hole in it, +-- represented here as a function +type TypeFn = Type -> Type + +-- a list of argument types extracted from a type application +type TypeContext = [Type] + +singFamilyName, singIName, singMethName, demoteRepName, singKindClassName, + sEqClassName, sEqMethName, sconsName, snilName, sIfName, undefinedName, + kProxyDataName, kProxyTypeName, someSingTypeName, someSingDataName, + nilName, consName, sListName, eqName, sDecideClassName, sDecideMethName, + provedName, disprovedName, reflName, toSingName, fromSingName, listName :: Name +singFamilyName = ''Sing +singIName = ''SingI +singMethName = 'sing +toSingName = 'toSing +fromSingName = 'fromSing +demoteRepName = ''DemoteRep +singKindClassName = ''SingKind +sEqClassName = mkName "SEq" +sEqMethName = mkName "%:==" +sIfName = mkName "sIf" +undefinedName = 'undefined +sconsName = mkName "SCons" +snilName = mkName "SNil" +kProxyDataName = 'KProxy +kProxyTypeName = ''KProxy +someSingTypeName = ''SomeSing +someSingDataName = 'SomeSing +nilName = '[] +consName = '(:) +listName = ''[] +sListName = mkName "SList" +eqName = ''Eq +sDecideClassName = ''SDecide +sDecideMethName = '(%~) +provedName = 'Proved +disprovedName = 'Disproved +reflName = 'Refl + +mkTupleName :: Int -> Name +mkTupleName n = mkName $ "STuple" ++ (show n) + +singFamily :: Type +singFamily = ConT singFamilyName + +singKindConstraint :: Kind -> Pred +singKindConstraint k = ClassP singKindClassName [kindParam k] + +demote :: Type +demote = ConT demoteRepName + +singDataConName :: Name -> Name +singDataConName nm + | nm == nilName = snilName + | nm == consName = sconsName + | Just degree <- tupleNameDegree_maybe nm = mkTupleName degree + | otherwise = prefixUCName "S" ":%" nm + +singTyConName :: Name -> Name +singTyConName name + | name == listName = sListName + | Just degree <- tupleNameDegree_maybe name = mkTupleName degree + | otherwise = prefixUCName "S" ":%" name + +singClassName :: Name -> Name +singClassName = singTyConName + +singDataCon :: Name -> Exp +singDataCon = ConE . singDataConName + +singValName :: Name -> Name +singValName n + | nameBase n == "undefined" = undefinedName + | otherwise = (prefixLCName "s" "%") $ upcase n + +singVal :: Name -> Exp +singVal = VarE . singValName + +kindParam :: Kind -> Type +kindParam k = SigT (ConT kProxyDataName) (AppT (ConT kProxyTypeName) k) + +-- | Generate singleton definitions from a type that is already defined. +-- For example, the singletons package itself uses +-- +-- > $(genSingletons [''Bool, ''Maybe, ''Either, ''[]]) +-- +-- to generate singletons for Prelude types. +genSingletons :: Quasi q => [Name] -> q [Dec] +genSingletons names = do + checkForRep names + concatMapM (singInfo <=< reifyWithWarning) names + +singInfo :: Quasi q => Info -> q [Dec] +singInfo (ClassI _dec _instances) = + fail "Singling of class info not supported" +singInfo (ClassOpI _name _ty _className _fixity) = + fail "Singling of class members info not supported" +singInfo (TyConI dec) = singDec dec +singInfo (FamilyI _dec _instances) = + fail "Singling of type family info not yet supported" -- KindFams +singInfo (PrimTyConI _name _numArgs _unlifted) = + fail "Singling of primitive type constructors not supported" +singInfo (DataConI _name _ty _tyname _fixity) = + fail $ "Singling of individual constructors not supported; " ++ + "single the type instead" +singInfo (VarI _name _ty _mdec _fixity) = + fail "Singling of value info not supported" +singInfo (TyVarI _name _ty) = + fail "Singling of type variable info not supported" + +-- refine a constructor. the first parameter is the type variable that +-- the singleton GADT is parameterized by +-- runs in the QWithDecs monad because auxiliary declarations are produced +singCtor :: Quasi q => Type -> Con -> QWithDecs q Con +singCtor a = ctorCases + -- monomorphic case + (\name types -> do + let sName = singDataConName name + sCon = singDataCon name + pCon = PromotedT name + indexNames <- replicateM (length types) (qNewName "n") + let indices = map VarT indexNames + kinds <- mapM promoteType types + args <- buildArgTypes types indices + let tvbs = zipWith KindedTV indexNames kinds + kindedIndices = zipWith SigT indices kinds + + -- SingI instance + addElement $ InstanceD (map (ClassP singIName . listify) indices) + (AppT (ConT singIName) + (foldType pCon kindedIndices)) + [ValD (VarP singMethName) + (NormalB $ foldExp sCon (replicate (length types) + (VarE singMethName))) + []] + + return $ ForallC tvbs + [EqualP a (foldType pCon indices)] + (NormalC sName $ map (NotStrict,) args)) + + -- polymorphic case + (\_tvbs cxt ctor -> case cxt of + _:_ -> fail "Singling of constrained constructors not yet supported" + [] -> singCtor a ctor) -- polymorphic constructors are handled just + -- like monomorphic ones -- the polymorphism in + -- the kind is automatic + where buildArgTypes :: Quasi q => [Type] -> [Type] -> q [Type] + buildArgTypes types indices = do + typeFns <- mapM singType types + return $ zipWith id typeFns indices + +-- | Make promoted and singleton versions of all declarations given, retaining +-- the original declarations. +-- See for +-- further explanation. +singletons :: Quasi q => q [Dec] -> q [Dec] +singletons = (>>= singDecs True) + +-- | Make promoted and singleton versions of all declarations given, discarding +-- the original declarations. +singletonsOnly :: Quasi q => q [Dec] -> q [Dec] +singletonsOnly = (>>= singDecs False) + +-- first parameter says whether or not to include original decls +singDecs :: Quasi q => Bool -> [Dec] -> q [Dec] +singDecs originals decls = do + promDecls <- promoteDecs decls + newDecls <- mapM singDec decls + return $ (if originals then (decls ++) else id) $ promDecls ++ (concat newDecls) + +singDec :: Quasi q => Dec -> q [Dec] +singDec (FunD name clauses) = do + let sName = singValName name + vars = Map.singleton name (VarE sName) + listify <$> FunD sName <$> (mapM (singClause vars) clauses) +singDec (ValD _ (GuardedB _) _) = + fail "Singling of definitions of values with a pattern guard not yet supported" +singDec (ValD _ _ (_:_)) = + fail "Singling of definitions of values with a <> clause not yet supported" +singDec (ValD pat (NormalB exp) []) = do + (sPat, vartbl) <- evalForPair $ singPat TopLevel pat + sExp <- singExp vartbl exp + return [ValD sPat (NormalB sExp) []] +singDec (DataD cxt name tvbs ctors derivings) = + singDataD False cxt name tvbs ctors derivings +singDec (NewtypeD cxt name tvbs ctor derivings) = + singDataD False cxt name tvbs [ctor] derivings +singDec (TySynD _name _tvbs _ty) = + fail "Singling of type synonyms not yet supported" +singDec (ClassD _cxt _name _tvbs _fundeps _decs) = + fail "Singling of class declaration not yet supported" +singDec (InstanceD _cxt _ty _decs) = + fail "Singling of class instance not yet supported" +singDec (SigD name ty) = do + tyTrans <- singType ty + return [SigD (singValName name) (tyTrans (promoteVal name))] +singDec (ForeignD fgn) = + let name = extractName fgn in do + qReportWarning $ "Singling of foreign functions not supported -- " ++ + (show name) ++ " ignored" + return [] + where extractName :: Foreign -> Name + extractName (ImportF _ _ _ n _) = n + extractName (ExportF _ _ n _) = n +singDec (InfixD fixity name) + | isUpcase name = return [InfixD fixity (singDataConName name)] + | otherwise = return [InfixD fixity (singValName name)] +singDec (PragmaD _prag) = do + qReportWarning "Singling of pragmas not supported" + return [] +singDec (FamilyD _flavour _name _tvbs _mkind) = + fail "Singling of type and data families not yet supported" +singDec (DataInstD _cxt _name _tys _ctors _derivings) = + fail "Singling of data instances not yet supported" +singDec (NewtypeInstD _cxt _name _tys _ctor _derivings) = + fail "Singling of newtype instances not yet supported" +#if __GLASGOW_HASKELL__ >= 707 +singDec (RoleAnnotD _name _roles) = + return [] -- silently ignore role annotations, as they're harmless +singDec (ClosedTypeFamilyD _name _tvs _mkind _eqns) = + fail "Singling of closed type families not yet supported" +singDec (TySynInstD _name _eqns) = +#else +singDec (TySynInstD _name _lhs _rhs) = +#endif + fail "Singling of type family instances not yet supported" + +-- | Create instances of 'SEq' and type-level '(:==)' for each type in the list +singEqInstances :: Quasi q => [Name] -> q [Dec] +singEqInstances = concatMapM singEqInstance + +-- | Create instance of 'SEq' and type-level '(:==)' for the given type +singEqInstance :: Quasi q => Name -> q [Dec] +singEqInstance name = do + promotion <- promoteEqInstance name + dec <- singEqualityInstance sEqClassDesc name + return $ dec : promotion + +-- | Create instances of 'SEq' (only -- no instance for '(:==)', which 'SEq' generally +-- relies on) for each type in the list +singEqInstancesOnly :: Quasi q => [Name] -> q [Dec] +singEqInstancesOnly = concatMapM singEqInstanceOnly + +-- | Create instances of 'SEq' (only -- no instance for '(:==)', which 'SEq' generally +-- relies on) for the given type +singEqInstanceOnly :: Quasi q => Name -> q [Dec] +singEqInstanceOnly name = listify <$> singEqualityInstance sEqClassDesc name + +-- | Create instances of 'SDecide' for each type in the list. +-- +-- Note that, due to a bug in GHC 7.6.3 (and lower) optimizing instances +-- for SDecide can make GHC hang. You may want to put +-- @{-# OPTIONS_GHC -O0 #-}@ in your file. +singDecideInstances :: Quasi q => [Name] -> q [Dec] +singDecideInstances = concatMapM singDecideInstance + +-- | Create instance of 'SDecide' for the given type. +-- +-- Note that, due to a bug in GHC 7.6.3 (and lower) optimizing instances +-- for SDecide can make GHC hang. You may want to put +-- @{-# OPTIONS_GHC -O0 #-}@ in your file. +singDecideInstance :: Quasi q => Name -> q [Dec] +singDecideInstance name = listify <$> singEqualityInstance sDecideClassDesc name + +-- generalized function for creating equality instances +singEqualityInstance :: Quasi q => EqualityClassDesc q -> Name -> q Dec +singEqualityInstance desc@(_, className, _) name = do + (tvbs, cons) <- getDataD ("I cannot make an instance of " ++ + show className ++ " for it.") name + let tyvars = map (VarT . extractTvbName) tvbs + kind = foldType (ConT name) tyvars + aName <- qNewName "a" + let aVar = VarT aName + scons <- mapM (evalWithoutAux . singCtor aVar) cons + mkEqualityInstance kind scons desc + +-- making the SEq instance and the SDecide instance are rather similar, +-- so we generalize +type EqualityClassDesc q = ((Con, Con) -> q Clause, Name, Name) +sEqClassDesc, sDecideClassDesc :: Quasi q => EqualityClassDesc q +sEqClassDesc = (mkEqMethClause, sEqClassName, sEqMethName) +sDecideClassDesc = (mkDecideMethClause, sDecideClassName, sDecideMethName) + +-- pass the *singleton* constructors, not the originals +mkEqualityInstance :: Quasi q => Kind -> [Con] + -> EqualityClassDesc q -> q Dec +mkEqualityInstance k ctors (mkMeth, className, methName) = do + let ctorPairs = [ (c1, c2) | c1 <- ctors, c2 <- ctors ] + methClauses <- if null ctors + then mkEmptyMethClauses + else mapM mkMeth ctorPairs + return $ InstanceD (map (\kvar -> ClassP className [kindParam kvar]) + (getKindVars k)) + (AppT (ConT className) + (kindParam k)) + [FunD methName methClauses] + where getKindVars :: Kind -> [Kind] + getKindVars (AppT l r) = getKindVars l ++ getKindVars r + getKindVars (VarT x) = [VarT x] + getKindVars (ConT _) = [] + getKindVars StarT = [] + getKindVars other = + error ("getKindVars sees an unusual kind: " ++ show other) + + mkEmptyMethClauses :: Quasi q => q [Clause] + mkEmptyMethClauses = do + a <- qNewName "a" + return [Clause [VarP a, WildP] (NormalB (CaseE (VarE a) emptyMatches)) []] + +mkEqMethClause :: Quasi q => (Con, Con) -> q Clause +mkEqMethClause (c1, c2) + | lname == rname = do + lnames <- replicateM lNumArgs (qNewName "a") + rnames <- replicateM lNumArgs (qNewName "b") + let lpats = map VarP lnames + rpats = map VarP rnames + lvars = map VarE lnames + rvars = map VarE rnames + return $ Clause + [ConP lname lpats, ConP rname rpats] + (NormalB $ + allExp (zipWith (\l r -> foldExp (VarE sEqMethName) [l, r]) + lvars rvars)) + [] + | otherwise = + return $ Clause + [ConP lname (replicate lNumArgs WildP), + ConP rname (replicate rNumArgs WildP)] + (NormalB (singDataCon falseName)) + [] + where allExp :: [Exp] -> Exp + allExp [] = singDataCon trueName + allExp [one] = one + allExp (h:t) = AppE (AppE (singVal andName) h) (allExp t) + + (lname, lNumArgs) = extractNameArgs c1 + (rname, rNumArgs) = extractNameArgs c2 + +mkDecideMethClause :: Quasi q => (Con, Con) -> q Clause +mkDecideMethClause (c1, c2) + | lname == rname = + if lNumArgs == 0 + then return $ Clause [ConP lname [], ConP rname []] + (NormalB (AppE (ConE provedName) (ConE reflName))) [] + else do + lnames <- replicateM lNumArgs (qNewName "a") + rnames <- replicateM lNumArgs (qNewName "b") + contra <- qNewName "contra" + let lpats = map VarP lnames + rpats = map VarP rnames + lvars = map VarE lnames + rvars = map VarE rnames + return $ Clause + [ConP lname lpats, ConP rname rpats] + (NormalB $ + CaseE (mkTupleExp $ + zipWith (\l r -> foldExp (VarE sDecideMethName) [l, r]) + lvars rvars) + ((Match (mkTuplePat (replicate lNumArgs + (ConP provedName [ConP reflName []]))) + (NormalB $ AppE (ConE provedName) (ConE reflName)) + []) : + [Match (mkTuplePat (replicate i WildP ++ + ConP disprovedName [VarP contra] : + replicate (lNumArgs - i - 1) WildP)) + (NormalB $ AppE (ConE disprovedName) + (LamE [ConP reflName []] + (AppE (VarE contra) + (ConE reflName)))) + [] | i <- [0..lNumArgs-1] ])) + [] + + | otherwise = + return $ Clause + [ConP lname (replicate lNumArgs WildP), + ConP rname (replicate rNumArgs WildP)] + (NormalB (AppE (ConE disprovedName) (LamCaseE emptyMatches))) + [] + + where + (lname, lNumArgs) = extractNameArgs c1 + (rname, rNumArgs) = extractNameArgs c2 + +-- the first parameter is True when we're refining the special case "Rep" +-- and false otherwise. We wish to consider the promotion of "Rep" to be * +-- not a promoted data constructor. +singDataD :: Quasi q => Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> q [Dec] +singDataD rep cxt name tvbs ctors derivings + | (_:_) <- cxt = fail "Singling of constrained datatypes is not supported" + | otherwise = do + aName <- qNewName "z" + let a = VarT aName + let tvbNames = map extractTvbName tvbs + k <- promoteType (foldType (ConT name) (map VarT tvbNames)) + (ctors', ctorInstDecls) <- evalForPair $ mapM (singCtor a) ctors + + -- instance for SingKind + fromSingClauses <- mapM mkFromSingClause ctors + toSingClauses <- mapM mkToSingClause ctors + let singKindInst = + InstanceD (map (singKindConstraint . VarT) tvbNames) + (AppT (ConT singKindClassName) + (kindParam k)) + [ mkTyFamInst demoteRepName + [kindParam k] + (foldType (ConT name) + (map (AppT demote . kindParam . VarT) tvbNames)) + , FunD fromSingName (fromSingClauses `orIfEmpty` emptyMethod aName) + , FunD toSingName (toSingClauses `orIfEmpty` emptyMethod aName) ] + + -- SEq instance + sEqInsts <- if elem eqName derivings + then mapM (mkEqualityInstance k ctors') [sEqClassDesc, sDecideClassDesc] + else return [] + + -- e.g. type SNat (a :: Nat) = Sing a + let kindedSynInst = + TySynD (singTyConName name) + [KindedTV aName k] + (AppT singFamily a) + + return $ (DataInstD [] singFamilyName [SigT a k] ctors' []) : + kindedSynInst : + singKindInst : + sEqInsts ++ + ctorInstDecls + where -- in the Rep case, the names of the constructors are in the wrong scope + -- (they're types, not datacons), so we have to reinterpret them. + mkConName :: Name -> Name + mkConName = if rep then reinterpret else id + + mkFromSingClause :: Quasi q => Con -> q Clause + mkFromSingClause c = do + let (cname, numArgs) = extractNameArgs c + varNames <- replicateM numArgs (qNewName "b") + return $ Clause [ConP (singDataConName cname) (map VarP varNames)] + (NormalB $ foldExp + (ConE $ mkConName cname) + (map (AppE (VarE fromSingName) . VarE) varNames)) + [] + + mkToSingClause :: Quasi q => Con -> q Clause + mkToSingClause = ctor1Case $ \cname types -> do + varNames <- mapM (const $ qNewName "b") types + svarNames <- mapM (const $ qNewName "c") types + promoted <- mapM promoteType types + let recursiveCalls = zipWith mkRecursiveCall varNames promoted + return $ + Clause [ConP (mkConName cname) (map VarP varNames)] + (NormalB $ + multiCase recursiveCalls + (map (ConP someSingDataName . listify . VarP) + svarNames) + (AppE (ConE someSingDataName) + (foldExp (ConE (singDataConName cname)) + (map VarE svarNames)))) + [] + + mkRecursiveCall :: Name -> Kind -> Exp + mkRecursiveCall var_name ki = + SigE (AppE (VarE toSingName) (VarE var_name)) + (AppT (ConT someSingTypeName) (kindParam ki)) + + emptyMethod :: Name -> [Clause] + emptyMethod n = [Clause [VarP n] (NormalB $ CaseE (VarE n) emptyMatches) []] + +singKind :: Quasi q => Kind -> q (Kind -> Kind) +singKind (ForallT _ _ _) = + fail "Singling of explicitly quantified kinds not yet supported" +singKind (VarT _) = fail "Singling of kind variables not yet supported" +singKind (ConT _) = fail "Singling of named kinds not yet supported" +singKind (TupleT _) = fail "Singling of tuple kinds not yet supported" +singKind (UnboxedTupleT _) = fail "Unboxed tuple used as kind" +singKind ArrowT = fail "Singling of unsaturated arrow kinds not yet supported" +singKind ListT = fail "Singling of list kinds not yet supported" +singKind (AppT (AppT ArrowT k1) k2) = do + k1fn <- singKind k1 + k2fn <- singKind k2 + k <- qNewName "k" + return $ \f -> AppT (AppT ArrowT (k1fn (VarT k))) (k2fn (AppT f (VarT k))) +singKind (AppT _ _) = fail "Singling of kind applications not yet supported" +singKind (SigT _ _) = + fail "Singling of explicitly annotated kinds not yet supported" +singKind (LitT _) = fail "Type literal used as kind" +singKind (PromotedT _) = fail "Promoted data constructor used as kind" +singKind (PromotedTupleT _) = fail "Promoted tuple used as kind" +singKind PromotedNilT = fail "Promoted nil used as kind" +singKind PromotedConsT = fail "Promoted cons used as kind" +singKind StarT = return $ \k -> AppT (AppT ArrowT k) StarT +singKind ConstraintT = fail "Singling of constraint kinds not yet supported" + +singType :: Quasi q => Type -> q TypeFn +singType ty = do -- replace with singTypeRec [] ty after GHC bug #??? is fixed + sTypeFn <- singTypeRec [] ty + return $ \inner_ty -> liftOutForalls $ sTypeFn inner_ty + +-- Lifts all foralls to the top-level. This is a workaround for bug #8031 on GHC +-- Trac +liftOutForalls :: Type -> Type +liftOutForalls = + go [] [] [] + where + go tyvars cxt args (ForallT tyvars1 cxt1 t1) + = go (reverse tyvars1 ++ tyvars) (reverse cxt1 ++ cxt) args t1 + go tyvars cxt args (SigT t1 _kind) -- ignore these kind annotations, which have to be * + = go tyvars cxt args t1 + go tyvars cxt args (AppT (AppT ArrowT arg1) res1) + = go tyvars cxt (arg1 : args) res1 + go [] [] args t1 + = mk_fun_ty (reverse args) t1 + go tyvars cxt args t1 + = ForallT (reverse tyvars) (reverse cxt) (mk_fun_ty (reverse args) t1) + + mk_fun_ty [] res = res + mk_fun_ty (arg1:args) res = AppT (AppT ArrowT arg1) (mk_fun_ty args res) + +-- the first parameter is the list of types the current type is applied to +singTypeRec :: Quasi q => TypeContext -> Type -> q TypeFn +singTypeRec (_:_) (ForallT _ _ _) = + fail "I thought this was impossible in Haskell. Email me at eir@cis.upenn.edu with your code if you see this message." +singTypeRec [] (ForallT _ [] ty) = -- Sing makes handling foralls automatic + singTypeRec [] ty +singTypeRec ctx (ForallT _tvbs cxt innerty) = do + cxt' <- singContext cxt + innerty' <- singTypeRec ctx innerty + return $ \ty -> ForallT [] cxt' (innerty' ty) +singTypeRec (_:_) (VarT _) = + fail "Singling of type variables of arrow kinds not yet supported" +singTypeRec [] (VarT _name) = + return $ \ty -> AppT singFamily ty +singTypeRec _ctx (ConT _name) = -- we don't need to process the context with Sing + return $ \ty -> AppT singFamily ty +singTypeRec _ctx (TupleT _n) = -- just like ConT + return $ \ty -> AppT singFamily ty +singTypeRec _ctx (UnboxedTupleT _n) = + fail "Singling of unboxed tuple types not yet supported" +singTypeRec ctx ArrowT = case ctx of + [ty1, ty2] -> do + t <- qNewName "t" + sty1 <- singTypeRec [] ty1 + sty2 <- singTypeRec [] ty2 + k1 <- promoteType ty1 + return (\f -> ForallT [KindedTV t k1] + [] + (AppT (AppT ArrowT (sty1 (VarT t))) + (sty2 (AppT f (VarT t))))) + _ -> fail "Internal error in Sing: converting ArrowT with improper context" +singTypeRec _ctx ListT = + return $ \ty -> AppT singFamily ty +singTypeRec ctx (AppT ty1 ty2) = + singTypeRec (ty2 : ctx) ty1 -- recur with the ty2 in the applied context +singTypeRec _ctx (SigT _ty _knd) = + fail "Singling of types with explicit kinds not yet supported" +singTypeRec _ctx (LitT _) = fail "Singling of type-level literals not yet supported" +singTypeRec _ctx (PromotedT _) = + fail "Singling of promoted data constructors not yet supported" +singTypeRec _ctx (PromotedTupleT _) = + fail "Singling of type-level tuples not yet supported" +singTypeRec _ctx PromotedNilT = fail "Singling of promoted nil not yet supported" +singTypeRec _ctx PromotedConsT = fail "Singling of type-level cons not yet supported" +singTypeRec _ctx StarT = fail "* used as type" +singTypeRec _ctx ConstraintT = fail "Constraint used as type" + +-- refine a constraint context +singContext :: Quasi q => Cxt -> q Cxt +singContext = mapM singPred + +singPred :: Quasi q => Pred -> q Pred +singPred (ClassP name tys) = do + kis <- mapM promoteType tys + let sName = singClassName name + return $ ClassP sName (map kindParam kis) +singPred (EqualP _ty1 _ty2) = + fail "Singling of type equality constraints not yet supported" + +singClause :: Quasi q => ExpTable -> Clause -> q Clause +singClause vars (Clause pats (NormalB exp) []) = do + (sPats, vartbl) <- evalForPair $ mapM (singPat Parameter) pats + let vars' = Map.union vartbl vars + sBody <- NormalB <$> singExp vars' exp + return $ Clause sPats sBody [] +singClause _ (Clause _ (GuardedB _) _) = + fail "Singling of guarded patterns not yet supported" +singClause _ (Clause _ _ (_:_)) = + fail "Singling of <> declarations not yet supported" + +type ExpsQ q = QWithAux ExpTable q + +-- we need to know where a pattern is to anticipate when +-- GHC's brain might explode +data PatternContext = LetBinding + | CaseStatement + | TopLevel + | Parameter + | Statement + deriving Eq + +checkIfBrainWillExplode :: Quasi q => PatternContext -> ExpsQ q () +checkIfBrainWillExplode CaseStatement = return () +checkIfBrainWillExplode Statement = return () +checkIfBrainWillExplode Parameter = return () +checkIfBrainWillExplode _ = + fail $ "Can't use a singleton pattern outside of a case-statement or\n" ++ + "do expression: GHC's brain will explode if you try. (Do try it!)" + +-- convert a pattern, building up the lexical scope as we go +singPat :: Quasi q => PatternContext -> Pat -> ExpsQ q Pat +singPat _patCxt (LitP _lit) = + fail "Singling of literal patterns not yet supported" +singPat patCxt (VarP name) = + let new = if patCxt == TopLevel then singValName name else name in do + addBinding name (VarE new) + return $ VarP new +singPat patCxt (TupP pats) = + singPat patCxt (ConP (tupleDataName (length pats)) pats) +singPat _patCxt (UnboxedTupP _pats) = + fail "Singling of unboxed tuples not supported" +singPat patCxt (ConP name pats) = do + checkIfBrainWillExplode patCxt + pats' <- mapM (singPat patCxt) pats + return $ ConP (singDataConName name) pats' +singPat patCxt (InfixP pat1 name pat2) = singPat patCxt (ConP name [pat1, pat2]) +singPat _patCxt (UInfixP _ _ _) = + fail "Singling of unresolved infix patterns not supported" +singPat _patCxt (ParensP _) = + fail "Singling of unresolved paren patterns not supported" +singPat patCxt (TildeP pat) = do + pat' <- singPat patCxt pat + return $ TildeP pat' +singPat patCxt (BangP pat) = do + pat' <- singPat patCxt pat + return $ BangP pat' +singPat patCxt (AsP name pat) = do + let new = if patCxt == TopLevel then singValName name else name in do + pat' <- singPat patCxt pat + addBinding name (VarE new) + return $ AsP name pat' +singPat _patCxt WildP = return WildP +singPat _patCxt (RecP _name _fields) = + fail "Singling of record patterns not yet supported" +singPat patCxt (ListP pats) = do + checkIfBrainWillExplode patCxt + sPats <- mapM (singPat patCxt) pats + return $ foldr (\elt lst -> ConP sconsName [elt, lst]) (ConP snilName []) sPats +singPat _patCxt (SigP _pat _ty) = + fail "Singling of annotated patterns not yet supported" +singPat _patCxt (ViewP _exp _pat) = + fail "Singling of view patterns not yet supported" + +singExp :: Quasi q => ExpTable -> Exp -> q Exp +singExp vars (VarE name) = case Map.lookup name vars of + Just exp -> return exp + Nothing -> return (singVal name) +singExp _vars (ConE name) = return $ singDataCon name +singExp _vars (LitE lit) = singLit lit +singExp vars (AppE exp1 exp2) = do + exp1' <- singExp vars exp1 + exp2' <- singExp vars exp2 + return $ AppE exp1' exp2' +singExp vars (InfixE mexp1 exp mexp2) = + case (mexp1, mexp2) of + (Nothing, Nothing) -> singExp vars exp + (Just exp1, Nothing) -> singExp vars (AppE exp exp1) + (Nothing, Just _exp2) -> + fail "Singling of right-only sections not yet supported" + (Just exp1, Just exp2) -> singExp vars (AppE (AppE exp exp1) exp2) +singExp _vars (UInfixE _ _ _) = + fail "Singling of unresolved infix expressions not supported" +singExp _vars (ParensE _) = + fail "Singling of unresolved paren expressions not supported" +singExp vars (LamE pats exp) = do + (pats', vartbl) <- evalForPair $ mapM (singPat Parameter) pats + let vars' = Map.union vartbl vars -- order matters; union is left-biased + exp' <- singExp vars' exp + return $ LamE pats' exp' +singExp _vars (LamCaseE _matches) = + fail "Singling of case expressions not yet supported" +singExp vars (TupE exps) = do + sExps <- mapM (singExp vars) exps + sTuple <- singExp vars (ConE (tupleDataName (length exps))) + return $ foldExp sTuple sExps +singExp _vars (UnboxedTupE _exps) = + fail "Singling of unboxed tuple not supported" +singExp vars (CondE bexp texp fexp) = do + exps <- mapM (singExp vars) [bexp, texp, fexp] + return $ foldExp (VarE sIfName) exps +singExp _vars (MultiIfE _alts) = + fail "Singling of multi-way if statements not yet supported" +singExp _vars (LetE _decs _exp) = + fail "Singling of let expressions not yet supported" +singExp _vars (CaseE _exp _matches) = + fail "Singling of case expressions not yet supported" +singExp _vars (DoE _stmts) = + fail "Singling of do expressions not yet supported" +singExp _vars (CompE _stmts) = + fail "Singling of list comprehensions not yet supported" +singExp _vars (ArithSeqE _range) = + fail "Singling of ranges not yet supported" +singExp vars (ListE exps) = do + sExps <- mapM (singExp vars) exps + return $ foldr (\x -> (AppE (AppE (ConE sconsName) x))) + (ConE snilName) sExps +singExp _vars (SigE _exp _ty) = + fail "Singling of annotated expressions not yet supported" +singExp _vars (RecConE _name _fields) = + fail "Singling of record construction not yet supported" +singExp _vars (RecUpdE _exp _fields) = + fail "Singling of record updates not yet supported" + +singLit :: Quasi q => Lit -> q Exp +singLit lit = SigE (VarE singMethName) <$> (AppT singFamily <$> (promoteLit lit)) diff --git a/src/Data/Singletons/TH.hs b/src/Data/Singletons/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TH.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ExplicitNamespaces, CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.TH +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- This module contains everything you need to derive your own singletons via +-- Template Haskell. +-- +-- TURN ON @-XScopedTypeVariables@ IN YOUR MODULE IF YOU WANT THIS TO WORK. +-- +---------------------------------------------------------------------------- + +module Data.Singletons.TH ( + -- * Primary Template Haskell generation functions + singletons, singletonsOnly, genSingletons, + promote, promoteOnly, + + -- ** Functions to generate equality instances + promoteEqInstances, promoteEqInstance, + singEqInstances, singEqInstance, + singEqInstancesOnly, singEqInstanceOnly, + singDecideInstances, singDecideInstance, + + -- ** Utility function + cases, + + -- * Basic singleton definitions + Sing(SFalse, STrue), SingI(..), SingKind(..), KindOf, Demote, + + -- * Auxiliary definitions + -- | These definitions might be mentioned in code generated by Template Haskell, + -- so they must be in scope. + + type (==), (:==), If, sIf, (:&&), SEq(..), + Any, + SDecide(..), (:~:)(..), Void, Refuted, Decision(..), + KProxy(..), SomeSing(..) + ) where + +import Data.Singletons +import Data.Singletons.Singletons +import Data.Singletons.Promote +import Data.Singletons.Instances +import Data.Singletons.Bool +import Data.Singletons.Eq +import Data.Singletons.Types +import Data.Singletons.Void +import Data.Singletons.Decide + +import GHC.Exts +import Language.Haskell.TH +import Language.Haskell.TH.Syntax ( Quasi(..) ) +import Language.Haskell.TH.Desugar +import Data.Singletons.Util +import Control.Applicative + +-- | The function 'cases' generates a case expression where each right-hand side +-- is identical. This may be useful if the type-checker requires knowledge of which +-- constructor is used to satisfy equality or type-class constraints, but where +-- each constructor is treated the same. +cases :: Quasi q + => Name -- ^ The head of the type of the scrutinee. (Like @''Maybe@ or @''Bool@.) + -> q Exp -- ^ The scrutinee, in a Template Haskell quote + -> q Exp -- ^ The body, in a Template Haskell quote + -> q Exp +cases tyName expq bodyq = do + info <- reifyWithWarning tyName + case info of + TyConI (DataD _ _ _ ctors _) -> buildCases ctors + TyConI (NewtypeD _ _ _ ctor _) -> buildCases [ctor] + _ -> fail $ "Using <> with something other than a type constructor: " + ++ (show tyName) + where buildCases ctors = + CaseE <$> expq <*> + mapM (\con -> Match (conToPat con) <$> + (NormalB <$> bodyq) <*> pure []) ctors + + conToPat :: Con -> Pat + conToPat = ctor1Case + (\name tys -> ConP name (map (const WildP) tys)) diff --git a/src/Data/Singletons/Tuple.hs b/src/Data/Singletons/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Tuple.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, DataKinds, PolyKinds, + RankNTypes, TypeFamilies, GADTs, CPP #-} + +#if __GLASGOW_HASKELL__ < 707 +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.Tuple +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines functions and datatypes relating to the singleton for tuples, +-- including a singletons version of all the definitions in @Data.Tuple@. +-- +-- Because many of these definitions are produced by Template Haskell, +-- it is not possible to create proper Haddock documentation. Please look +-- up the corresponding operation in @Data.Tuple@. Also, please excuse +-- the apparent repeated variable names. This is due to an interaction +-- between Template Haskell and Haddock. +-- +---------------------------------------------------------------------------- + +module Data.Singletons.Tuple ( + -- * Singleton definitions + -- | See 'Data.Singletons.Prelude.Sing' for more info. + Sing(STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7), + STuple0, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7, + + -- * Singletons from @Data.Tuple@ + Fst, sFst, Snd, sSnd, Curry, sCurry, Uncurry, sUncurry, Swap, sSwap + ) where + +import Data.Singletons.Instances +import Data.Singletons.TH + +$(singletonsOnly [d| + -- | Extract the first component of a pair. + fst :: (a,b) -> a + fst (x,_) = x + + -- | Extract the second component of a pair. + snd :: (a,b) -> b + snd (_,y) = y + + -- | 'curry' converts an uncurried function to a curried function. + curry :: ((a, b) -> c) -> a -> b -> c + curry f x y = f (x, y) + + -- | 'uncurry' converts a curried function to a function on pairs. + uncurry :: (a -> b -> c) -> ((a, b) -> c) + uncurry f p = f (fst p) (snd p) + + -- | Swap the components of a pair. + swap :: (a,b) -> (b,a) + swap (a,b) = (b,a) + |]) diff --git a/src/Data/Singletons/TypeLits.hs b/src/Data/Singletons/TypeLits.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TypeLits.hs @@ -0,0 +1,181 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.TypeLits +-- Copyright : (C) 2014 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines and exports singletons useful for the Nat and Symbol kinds. +-- +---------------------------------------------------------------------------- + +{-# LANGUAGE CPP, PolyKinds, DataKinds, TypeFamilies, FlexibleInstances, + UndecidableInstances, ScopedTypeVariables, RankNTypes, + GADTs, FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +#if __GLASGOW_HASKELL__ < 707 +{-# OPTIONS_GHC -O0 #-} -- don't optimize SDecide instances in 7.6! +#endif + +module Data.Singletons.TypeLits ( + Nat, Symbol, + SNat, SSymbol, withKnownNat, withKnownSymbol, + Error, sError, + KnownNat, natVal, KnownSymbol, symbolVal + ) where + +import Data.Singletons +import Data.Singletons.Types +import Data.Singletons.Eq +import Data.Singletons.Decide +import Data.Singletons.Bool +#if __GLASGOW_HASKELL__ >= 707 +import GHC.TypeLits +#else +import GHC.TypeLits (Nat, Symbol) +import qualified GHC.TypeLits as TL +#endif +import Unsafe.Coerce + +---------------------------------------------------------------------- +---- TypeLits singletons --------------------------------------------- +---------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 707 +data instance Sing (n :: Nat) = KnownNat n => SNat + +instance KnownNat n => SingI n where + sing = SNat + +instance SingKind ('KProxy :: KProxy Nat) where + type DemoteRep ('KProxy :: KProxy Nat) = Integer + fromSing (SNat :: Sing n) = natVal (Proxy :: Proxy n) + toSing n = case someNatVal n of + Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNat :: Sing n) + Nothing -> error "Negative singleton nat" + +data instance Sing (n :: Symbol) = KnownSymbol n => SSym + +instance KnownSymbol n => SingI n where + sing = SSym + +instance SingKind ('KProxy :: KProxy Symbol) where + type DemoteRep ('KProxy :: KProxy Symbol) = String + fromSing (SSym :: Sing n) = symbolVal (Proxy :: Proxy n) + toSing s = case someSymbolVal s of + SomeSymbol (_ :: Proxy n) -> SomeSing (SSym :: Sing n) + +#else + +data TLSingInstance (a :: k) where + TLSingInstance :: TL.SingI a => TLSingInstance a + +newtype DI a = Don'tInstantiate (TL.SingI a => TLSingInstance a) + +tlSingInstance :: forall (a :: k). TL.Sing a -> TLSingInstance a +tlSingInstance s = with_sing_i TLSingInstance + where + with_sing_i :: (TL.SingI a => TLSingInstance a) -> TLSingInstance a + with_sing_i si = unsafeCoerce (Don'tInstantiate si) s + +withTLSingI :: TL.Sing n -> (TL.SingI n => r) -> r +withTLSingI sn r = + case tlSingInstance sn of + TLSingInstance -> r + +data instance Sing (n :: Nat) = TL.SingRep n Integer => SNat + +instance TL.SingRep n Integer => SingI (n :: Nat) where + sing = SNat + +instance SingKind ('KProxy :: KProxy Nat) where + type DemoteRep ('KProxy :: KProxy Nat) = Integer + fromSing (SNat :: Sing n) = TL.fromSing (TL.sing :: TL.Sing n) + toSing n + | n >= 0 = case TL.unsafeSingNat n of + (tlsing :: TL.Sing n) -> + withTLSingI tlsing (SomeSing (SNat :: Sing n)) + | otherwise = error "Negative singleton nat" + +data instance Sing (n :: Symbol) = TL.SingRep n String => SSym + +instance TL.SingRep n String => SingI (n :: Symbol) where + sing = SSym + +instance SingKind ('KProxy :: KProxy Symbol) where + type DemoteRep ('KProxy :: KProxy Symbol) = String + fromSing (SSym :: Sing n) = TL.fromSing (TL.sing :: TL.Sing n) + toSing n = case TL.unsafeSingSymbol n of + (tlsing :: TL.Sing n) -> + withTLSingI tlsing (SomeSing (SSym :: Sing n)) + +-- create 7.8-style TypeLits definitions: +class KnownNat (n :: Nat) where + natVal :: proxy n -> Integer + +class KnownSymbol (n :: Symbol) where + symbolVal :: proxy n -> String + +instance TL.SingI n => KnownNat n where + natVal _ = TL.fromSing (TL.sing :: TL.Sing n) + +instance TL.SingI n => KnownSymbol n where + symbolVal _ = TL.fromSing (TL.sing :: TL.Sing n) + +#endif + +-- SDecide instances: +instance SDecide ('KProxy :: KProxy Nat) where + (SNat :: Sing n) %~ (SNat :: Sing m) + | natVal (Proxy :: Proxy n) == natVal (Proxy :: Proxy m) + = Proved $ unsafeCoerce Refl + | otherwise + = Disproved (\_ -> error errStr) + where errStr = "Broken Nat singletons" + +instance SDecide ('KProxy :: KProxy Symbol) where + (SSym :: Sing n) %~ (SSym :: Sing m) + | symbolVal (Proxy :: Proxy n) == symbolVal (Proxy :: Proxy m) + = Proved $ unsafeCoerce Refl + | otherwise + = Disproved (\_ -> error errStr) + where errStr = "Broken Symbol singletons" + +-- need SEq instances for TypeLits kinds +instance SEq ('KProxy :: KProxy Nat) where + a %:== b + | fromSing a == fromSing b = unsafeCoerce STrue + | otherwise = unsafeCoerce SFalse + +instance SEq ('KProxy :: KProxy Symbol) where + a %:== b + | fromSing a == fromSing b = unsafeCoerce STrue + | otherwise = unsafeCoerce SFalse + +-- | Kind-restricted synonym for 'Sing' for @Nat@s +type SNat (x :: Nat) = Sing x + +-- | Kind-restricted synonym for 'Sing' for @Symbol@s +type SSymbol (x :: Symbol) = Sing x + +-- Convenience functions + +-- | Given a singleton for @Nat@, call something requiring a +-- @KnownNat@ instance. +withKnownNat :: Sing n -> (KnownNat n => r) -> r +withKnownNat SNat f = f + +-- | Given a singleton for @Symbol@, call something requiring +-- a @KnownSymbol@ instance. +withKnownSymbol :: Sing n -> (KnownSymbol n => r) -> r +withKnownSymbol SSym f = f + +-- | The promotion of 'error' +type family Error (str :: Symbol) :: k + +-- | The singleton for 'error' +sError :: Sing (str :: Symbol) -> a +sError sstr = error (fromSing sstr) diff --git a/src/Data/Singletons/TypeRepStar.hs b/src/Data/Singletons/TypeRepStar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/TypeRepStar.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE RankNTypes, TypeFamilies, KindSignatures, FlexibleInstances, + GADTs, UndecidableInstances, ScopedTypeVariables, DataKinds, + MagicHash, CPP, TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.TypeRepStar +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- This module defines singleton instances making 'Typeable' the singleton for +-- the kind @*@. The definitions don't fully line up with what is expected +-- within the singletons library, so expect unusual results! +-- +---------------------------------------------------------------------------- + +module Data.Singletons.TypeRepStar ( + Sing(STypeRep) + -- | Here is the definition of the singleton for @*@: + -- + -- > data instance Sing (a :: *) where + -- > STypeRep :: Typeable a => Sing a + -- + -- Instances for 'SingI', 'SingKind', 'SEq', 'SDecide', and 'TestCoercion' are + -- also supplied. + ) where + +import Data.Singletons.Instances +import Data.Singletons +import Data.Singletons.Types +import Data.Singletons.Eq +import Data.Typeable +import Unsafe.Coerce +import Data.Singletons.Decide + +#if __GLASGOW_HASKELL__ >= 707 +import GHC.Exts ( Proxy# ) +import Data.Type.Coercion +#else + +eqT :: (Typeable a, Typeable b) => Maybe (a :~: b) +eqT = gcast Refl + +type instance (a :: *) :== (a :: *) = True + +#endif + +data instance Sing (a :: *) where + STypeRep :: Typeable a => Sing a + +instance Typeable a => SingI (a :: *) where + sing = STypeRep +instance SingKind ('KProxy :: KProxy *) where + type DemoteRep ('KProxy :: KProxy *) = TypeRep + fromSing (STypeRep :: Sing a) = typeOf (undefined :: a) + toSing = dirty_mk_STypeRep + +instance SEq ('KProxy :: KProxy *) where + (STypeRep :: Sing a) %:== (STypeRep :: Sing b) = + case (eqT :: Maybe (a :~: b)) of + Just Refl -> STrue + Nothing -> unsafeCoerce SFalse + -- the Data.Typeable interface isn't strong enough + -- to enable us to define this without unsafeCoerce + +instance SDecide ('KProxy :: KProxy *) where + (STypeRep :: Sing a) %~ (STypeRep :: Sing b) = + case (eqT :: Maybe (a :~: b)) of + Just Refl -> Proved Refl + Nothing -> Disproved (\Refl -> error "Data.Typeable.eqT failed") + +#if __GLASGOW_HASKELL__ >= 707 +-- TestEquality instance already defined, but we need this one: +instance TestCoercion Sing where + testCoercion (STypeRep :: Sing a) (STypeRep :: Sing b) = + case (eqT :: Maybe (a :~: b)) of + Just Refl -> Just Coercion + Nothing -> Nothing +#endif + +-- everything below here is private and dirty. Don't look! + +newtype DI = Don'tInstantiate (Typeable a => Sing a) +dirty_mk_STypeRep :: TypeRep -> SomeSing ('KProxy :: KProxy *) +dirty_mk_STypeRep rep = +#if __GLASGOW_HASKELL__ >= 707 + let justLikeTypeable :: Proxy# a -> TypeRep + justLikeTypeable _ = rep + in +#else + let justLikeTypeable :: a -> TypeRep + justLikeTypeable _ = rep + in +#endif + unsafeCoerce (Don'tInstantiate STypeRep) justLikeTypeable diff --git a/src/Data/Singletons/Types.hs b/src/Data/Singletons/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Types.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE PolyKinds, TypeOperators, GADTs, RankNTypes, TypeFamilies, + CPP, DataKinds #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.Types +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines and exports types that are useful when working with singletons. +-- Some of these are re-exports from @Data.Type.Equality@. +-- +---------------------------------------------------------------------------- + + +module Data.Singletons.Types ( + KProxy(..), Proxy(..), + (:~:)(..), gcastWith, TestEquality(..), + Not, If, type (==), (:==) + ) where + +#if __GLASGOW_HASKELL__ < 707 + +-- now in Data.Proxy +data KProxy (a :: *) = KProxy +data Proxy a = Proxy + +-- now in Data.Type.Equality +data a :~: b where + Refl :: a :~: a + +gcastWith :: (a :~: b) -> ((a ~ b) => r) -> r +gcastWith Refl x = x + +class TestEquality (f :: k -> *) where + testEquality :: f a -> f b -> Maybe (a :~: b) + +-- now in Data.Type.Bool +-- | Type-level "If". @If True a b@ ==> @a@; @If False a b@ ==> @b@ +type family If (a :: Bool) (b :: k) (c :: k) :: k +type instance If 'True b c = b +type instance If 'False b c = c + +type family (a :: k) :== (b :: k) :: Bool +type a == b = a :== b + +type family Not (b :: Bool) :: Bool +type instance Not True = False +type instance Not False = True + +#else + +import Data.Proxy +import Data.Type.Equality +import Data.Type.Bool + +-- | A re-export of the type-level @(==)@ that conforms to the singletons naming +-- convention. +type a :== b = a == b + +#endif diff --git a/src/Data/Singletons/Util.hs b/src/Data/Singletons/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Util.hs @@ -0,0 +1,267 @@ +{- Data/Singletons/Util.hs + +(c) Richard Eisenberg 2013 +eir@cis.upenn.edu + +This file contains helper functions internal to the singletons package. +Users of the package should not need to consult this file. +-} + +{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, RankNTypes, + TemplateHaskell, GeneralizedNewtypeDeriving, + MultiParamTypeClasses #-} + +module Data.Singletons.Util ( + module Data.Singletons.Util, + module Language.Haskell.TH.Desugar ) + where + +import Prelude hiding ( exp ) +import Language.Haskell.TH hiding ( Q ) +import Language.Haskell.TH.Syntax ( Quasi(..) ) +import Language.Haskell.TH.Desugar ( reifyWithWarning, getDataD ) +import Data.Char +import Control.Monad +import Control.Applicative +import Control.Monad.Writer +import qualified Data.Map as Map + +mkTyFamInst :: Name -> [Type] -> Type -> Dec +mkTyFamInst name lhs rhs = +#if __GLASGOW_HASKELL__ >= 707 + TySynInstD name (TySynEqn lhs rhs) +#else + TySynInstD name lhs rhs +#endif + +-- The list of types that singletons processes by default +basicTypes :: [Name] +basicTypes = [ ''Bool + , ''Maybe + , ''Either + , ''Ordering + , ''[] + , ''() + , ''(,) + , ''(,,) + , ''(,,,) + , ''(,,,,) + , ''(,,,,,) + , ''(,,,,,,) + ] + +-- like newName, but even more unique (unique across different splices) +-- TH doesn't allow "newName"s to work at the top-level, so we have to +-- do this trick to ensure the Extract functions are unique +newUniqueName :: Quasi q => String -> q Name +newUniqueName str = do + n <- qNewName str + return $ mkName $ show n + +-- like reportWarning, but generalized to any Quasi +qReportWarning :: Quasi q => String -> q () +qReportWarning = qReport False + +-- like reportError, but generalized to any Quasi +qReportError :: Quasi q => String -> q () +qReportError = qReport True + +-- extract the degree of a tuple +tupleDegree_maybe :: String -> Maybe Int +tupleDegree_maybe s = do + '(' : s1 <- return s + (commas, ")") <- return $ span (== ',') s1 + let degree + | "" <- commas = 0 + | otherwise = length commas + 1 + return degree + +-- extract the degree of a tuple name +tupleNameDegree_maybe :: Name -> Maybe Int +tupleNameDegree_maybe = tupleDegree_maybe . nameBase + +-- reduce the four cases of a 'Con' to just two: monomorphic and polymorphic +-- and convert 'StrictType' to 'Type' +ctorCases :: (Name -> [Type] -> a) -> ([TyVarBndr] -> Cxt -> Con -> a) -> Con -> a +ctorCases genFun forallFun ctor = case ctor of + NormalC name stypes -> genFun name (map snd stypes) + RecC name vstypes -> genFun name (map (\(_,_,ty) -> ty) vstypes) + InfixC (_,ty1) name (_,ty2) -> genFun name [ty1, ty2] + ForallC [] [] ctor' -> ctorCases genFun forallFun ctor' + ForallC tvbs cx ctor' -> forallFun tvbs cx ctor' + +-- reduce the four cases of a 'Con' to just 1: a polymorphic Con is treated +-- as a monomorphic one +ctor1Case :: (Name -> [Type] -> a) -> Con -> a +ctor1Case mono = ctorCases mono (\_ _ ctor -> ctor1Case mono ctor) + +-- extract the name and number of arguments to a constructor +extractNameArgs :: Con -> (Name, Int) +extractNameArgs = ctor1Case (\name tys -> (name, length tys)) + +-- reinterpret a name. This is useful when a Name has an associated +-- namespace that we wish to forget +reinterpret :: Name -> Name +reinterpret = mkName . nameBase + +-- is an identifier uppercase? +isUpcase :: Name -> Bool +isUpcase n = let first = head (nameBase n) in isUpper first || first == ':' + +-- make an identifier uppercase +upcase :: Name -> Name +upcase n = + let str = nameBase n + first = head str in + if isLetter first + then mkName ((toUpper first) : tail str) + else mkName (':' : str) + +-- make an identifier lowercase +locase :: Name -> Name +locase n = + let str = nameBase n + first = head str in + if isLetter first + then mkName ((toLower first) : tail str) + else mkName (tail str) -- remove the ":" + +-- put an uppercase prefix on a name. Takes two prefixes: one for identifiers +-- and one for symbols +prefixUCName :: String -> String -> Name -> Name +prefixUCName pre tyPre n = case (nameBase n) of + (':' : rest) -> mkName (tyPre ++ rest) + alpha -> mkName (pre ++ alpha) + +-- put a lowercase prefix on a name. Takes two prefixes: one for identifiers +-- and one for symbols +prefixLCName :: String -> String -> Name -> Name +prefixLCName pre tyPre n = + let str = nameBase n + first = head str in + if isLetter first + then mkName (pre ++ str) + else mkName (tyPre ++ str) + +-- extract the kind from a TyVarBndr. Returns '*' by default. +extractTvbKind :: TyVarBndr -> Kind +extractTvbKind (PlainTV _) = StarT -- FIXME: This seems wrong. +extractTvbKind (KindedTV _ k) = k + +-- extract the name from a TyVarBndr. +extractTvbName :: TyVarBndr -> Name +extractTvbName (PlainTV n) = n +extractTvbName (KindedTV n _) = n + +-- apply a type to a list of types +foldType :: Type -> [Type] -> Type +foldType = foldl AppT + +-- apply an expression to a list of expressions +foldExp :: Exp -> [Exp] -> Exp +foldExp = foldl AppE + +-- is a kind a variable? +isVarK :: Kind -> Bool +isVarK (VarT _) = True +isVarK _ = False + +-- tuple up a list of expressions +mkTupleExp :: [Exp] -> Exp +mkTupleExp [x] = x +mkTupleExp xs = TupE xs + +-- tuple up a list of patterns +mkTuplePat :: [Pat] -> Pat +mkTuplePat [x] = x +mkTuplePat xs = TupP xs + +-- choose the first non-empty list +orIfEmpty :: [a] -> [a] -> [a] +orIfEmpty [] x = x +orIfEmpty x _ = x + +-- an empty list of matches, compatible with GHC 7.6.3 +emptyMatches :: [Match] +emptyMatches = [Match WildP (NormalB (AppE (VarE 'error) (LitE (StringL errStr)))) []] + where errStr = "Empty case reached -- this should be impossible" + +-- build a pattern match over several expressions, each with only one pattern +multiCase :: [Exp] -> [Pat] -> Exp -> Exp +multiCase [] [] body = body +multiCase scruts pats body = + CaseE (mkTupleExp scruts) + [Match (mkTuplePat pats) (NormalB body) []] + +-- a monad transformer for writing a monoid alongside returning a Q +newtype QWithAux m q a = QWA { runQWA :: WriterT m q a } + deriving (Functor, Applicative, Monad, MonadTrans) + +instance (Monoid m, Monad q) => MonadWriter m (QWithAux m q) where + writer = QWA . writer + tell = QWA . tell + listen = QWA . listen . runQWA + pass = QWA . pass . runQWA + +-- make a Quasi instance for easy lifting +instance (Quasi q, Monoid m) => Quasi (QWithAux m q) where + qNewName = lift `comp1` qNewName + qReport = lift `comp2` qReport + qLookupName = lift `comp2` qLookupName + qReify = lift `comp1` qReify + qReifyInstances = lift `comp2` qReifyInstances + qLocation = lift qLocation + qRunIO = lift `comp1` qRunIO + qAddDependentFile = lift `comp1` qAddDependentFile +#if __GLASGOW_HASKELL__ >= 707 + qReifyRoles = lift `comp1` qReifyRoles + qReifyAnnotations = lift `comp1` qReifyAnnotations + qReifyModule = lift `comp1` qReifyModule + qAddTopDecls = lift `comp1` qAddTopDecls + qAddModFinalizer = lift `comp1` qAddModFinalizer + qGetQ = lift qGetQ + qPutQ = lift `comp1` qPutQ +#endif + + qRecover exp handler = do + (result, aux) <- lift $ qRecover (evalForPair exp) (evalForPair handler) + tell aux + return result + +-- helper functions for composition +comp1 :: (b -> c) -> (a -> b) -> a -> c +comp1 = (.) + +comp2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d +comp2 f g a b = f (g a b) + +-- run a computation with an auxiliary monoid, discarding the monoid result +evalWithoutAux :: Quasi q => QWithAux m q a -> q a +evalWithoutAux = liftM fst . runWriterT . runQWA + +-- run a computation with an auxiliary monoid, returning only the monoid result +evalForAux :: Quasi q => QWithAux m q a -> q m +evalForAux = execWriterT . runQWA + +-- run a computation with an auxiliary monoid, return both the result +-- of the computation and the monoid result +evalForPair :: Quasi q => QWithAux m q a -> q (a, m) +evalForPair = runWriterT . runQWA + +-- in a computation with an auxiliary map, add a binding to the map +addBinding :: (Quasi q, Ord k) => k -> v -> QWithAux (Map.Map k v) q () +addBinding k v = tell (Map.singleton k v) + +-- in a computation with an auxiliar list, add an element to the list +addElement :: Quasi q => elt -> QWithAux [elt] q () +addElement elt = tell [elt] + +-- lift concatMap into a monad +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM fn list = do + bss <- mapM fn list + return $ concat bss + +-- make a one-element list +listify :: a -> [a] +listify = return diff --git a/src/Data/Singletons/Void.hs b/src/Data/Singletons/Void.hs new file mode 100644 --- /dev/null +++ b/src/Data/Singletons/Void.hs @@ -0,0 +1,78 @@ +{- Data/Singletons/Void.hs + + A reimplementation of a Void type, copied shamelessly from Edward Kmett's void + package, but without inducing a dependency. + +-} + +{-# LANGUAGE CPP, Trustworthy, DeriveDataTypeable, DeriveGeneric, StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2008-2013 Edward Kmett +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- This module is a reimplementation of Edward Kmett's @void@ package. +-- It is included within singletons to avoid depending on @void@ and all the +-- packages that depends on (including @text@). If this causes problems for +-- you (that singletons has its own 'Void' type), please let me (Richard Eisenberg) +-- know at @eir@ at @cis.upenn.edu@. +-- +---------------------------------------------------------------------------- +module Data.Singletons.Void + ( Void + , absurd + , vacuous + , vacuousM + ) where + +import Control.Monad (liftM) +import Data.Ix +import Data.Data +import GHC.Generics +import Control.Exception + +-- | A logically uninhabited data type. +newtype Void = Void Void + deriving (Data, Typeable, Generic) + +instance Eq Void where + _ == _ = True + +instance Ord Void where + compare _ _ = EQ + +instance Show Void where + showsPrec _ = absurd + +-- | Reading a 'Void' value is always a parse error, considering 'Void' as +-- a data type with no constructors. +instance Read Void where + readsPrec _ _ = [] + +-- | Since 'Void' values logically don't exist, this witnesses the logical +-- reasoning tool of \"ex falso quodlibet\". +absurd :: Void -> a +absurd a = a `seq` spin a where + spin (Void b) = spin b + +-- | If 'Void' is uninhabited then any 'Functor' that holds only values of type 'Void' +-- is holding no values. +vacuous :: Functor f => f Void -> f a +vacuous = fmap absurd + +-- | If 'Void' is uninhabited then any 'Monad' that holds values of type 'Void' +-- is holding no values. +vacuousM :: Monad m => m Void -> m a +vacuousM = liftM absurd + +instance Ix Void where + range _ = [] + index _ = absurd + inRange _ = absurd + rangeSize _ = 0 + +instance Exception Void diff --git a/tests/SingletonsTestSuite.hs b/tests/SingletonsTestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/SingletonsTestSuite.hs @@ -0,0 +1,41 @@ +module Main ( + main + ) where + +import Test.Tasty ( TestTree, defaultMain, testGroup ) +import SingletonsTestSuiteUtils ( compileAndDumpStdTest, compileAndDumpTest + , testCompileAndDumpGroup, ghcOpts ) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup "Testsuite" $ [ + testCompileAndDumpGroup "Singletons" + [ compileAndDumpStdTest "Nat" + , compileAndDumpStdTest "Empty" + , compileAndDumpStdTest "Maybe" + , compileAndDumpStdTest "BoxUnBox" + , compileAndDumpStdTest "Operators" + , compileAndDumpStdTest "BadPlus" + , compileAndDumpStdTest "HigherOrder" + , compileAndDumpStdTest "Contains" + , compileAndDumpStdTest "AtPattern" + , compileAndDumpStdTest "DataValues" + , compileAndDumpStdTest "EqInstances" + , compileAndDumpStdTest "Star" + ], + testCompileAndDumpGroup "Promote" + [ compileAndDumpStdTest "PatternMatching" + , compileAndDumpStdTest "NumArgs" -- remove once we have eta-expansion + ], + testGroup "Database client" + [ compileAndDumpTest "GradingClient/Database" ghcOpts + , compileAndDumpTest "GradingClient/Main" ghcOpts + ], + testCompileAndDumpGroup "InsertionSort" + [ compileAndDumpStdTest "InsertionSortImp" + ] + ] + diff --git a/tests/SingletonsTestSuiteUtils.hs b/tests/SingletonsTestSuiteUtils.hs new file mode 100644 --- /dev/null +++ b/tests/SingletonsTestSuiteUtils.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE CPP, DeriveDataTypeable #-} +module SingletonsTestSuiteUtils ( + compileAndDumpTest + , compileAndDumpStdTest + , testCompileAndDumpGroup + , ghcOpts + , singletonsVersion + ) where + +import Control.Exception ( Exception, throw ) +import Data.List ( intercalate ) +import Data.Typeable ( Typeable ) +import System.Exit ( ExitCode(..) ) +import System.FilePath ( takeBaseName, pathSeparator ) +import System.IO ( IOMode(..), hGetContents, openFile ) +import System.Process ( CreateProcess(..), StdStream(..) + , createProcess, proc, waitForProcess ) +import Test.Tasty ( TestTree, testGroup ) +import Test.Tasty.Golden ( goldenVsFileDiff ) + +import Distribution.PackageDescription.Parse ( readPackageDescription ) +import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) +import Distribution.PackageDescription ( PackageDescription(..) ) +import Distribution.Verbosity ( silent ) +import Distribution.Package ( PackageIdentifier(..) ) +import Data.Version ( showVersion ) +import System.IO.Unsafe ( unsafePerformIO ) + +-- Some infractructure for handling external process errors +data ProcessException = ProcessException String deriving (Typeable) + +instance Exception ProcessException + +instance Show ProcessException where + show (ProcessException msg) = msg + +-- GHC executable name (if on path) or full path +ghcPath :: FilePath +ghcPath = "ghc" + +-- directory storing compile-and-run tests and golden files +goldenPath :: FilePath +goldenPath = "tests/compile-and-dump/" + +-- path containing compiled *.hi files. Relative to goldenPath. +-- See Note [-package-name hack] +includePath :: FilePath +includePath = "../../dist/build" + +ghcVersion :: String +#if __GLASGOW_HASKELL__ < 706 +ghcVersion = error "testsuite requires GHC 7.6 or newer" +#else +#if __GLASGOW_HASKELL__ >= 706 && __GLASGOW_HASKELL__ < 707 +ghcVersion = ".ghc76" +#else +ghcVersion = ".ghc78" +#endif +#endif + +-- the version number of "singletons" +singletonsVersion :: String +singletonsVersion = unsafePerformIO $ do + gpd <- readPackageDescription silent "singletons.cabal" + let pd = flattenPackageDescription gpd + return $ showVersion $ pkgVersion $ package pd + +-- GHC options used when running the tests +ghcOpts :: [String] +ghcOpts = [ + "-v0" + , "-c" + , "-package-name singletons-" ++ singletonsVersion -- See Note [-package-name hack] + , "-ddump-splices" + , "-dsuppress-uniques" + , "-fforce-recomp" + , "-i" ++ includePath + , "-XTemplateHaskell" + , "-XDataKinds" + , "-XKindSignatures" + , "-XTypeFamilies" + , "-XTemplateHaskell" + , "-XTypeOperators" + , "-XKindSignatures" + , "-XDataKinds" + , "-XMultiParamTypeClasses" + , "-XGADTs" + , "-XTypeFamilies" + , "-XFlexibleInstances" + , "-XUndecidableInstances" + , "-XRankNTypes" + , "-XScopedTypeVariables" + , "-XPolyKinds" + , "-XFlexibleContexts" + , "-XIncoherentInstances" + , "-XCPP" + ] + +-- Note [-package-name hack] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We want to avoid installing singletons package before running the +-- testsuite, because in this way we prevent double compilation of the +-- library. To do this we pass -package-name option to GHC to convince +-- it that the test files are actually part of the current +-- package. This means that library doesn't have to be installed +-- globally and interface files generated during library compilation +-- can be used when compiling test cases. We use "-i" option to point +-- GHC to directory containing compiled interface files. + +-- Compile a test using specified GHC options. Save output to file, filter with +-- sed and compare it with golden file. This function also builds golden file +-- from a template file. Putting it here is a bit of a hack but it's easy and it +-- works. +-- +-- First parameter is a path to the test file relative to goldenPath directory +-- with no ".hs". +compileAndDumpTest :: FilePath -> [String] -> TestTree +compileAndDumpTest testName opts = + goldenVsFileDiff + (takeBaseName testName) + (\ref new -> ["diff", "-w", "-B", ref, new]) -- see Note [Diff options] + goldenFilePath + actualFilePath + compileWithGHC + where + testPath = testName ++ ".hs" + templateFilePath = goldenPath ++ testName ++ ghcVersion ++ ".template" + goldenFilePath = goldenPath ++ testName ++ ".golden" + actualFilePath = goldenPath ++ testName ++ ".actual" + + compileWithGHC :: IO () + compileWithGHC = do + hActualFile <- openFile actualFilePath WriteMode + (_, _, _, pid) <- createProcess (proc ghcPath (testPath : opts)) + { std_out = UseHandle hActualFile + , std_err = UseHandle hActualFile + , cwd = Just goldenPath } + _ <- waitForProcess pid -- see Note [Ignore exit code] + filterWithSed actualFilePath -- see Note [Normalization with sed] + buildGoldenFile templateFilePath goldenFilePath + return () + +-- Compile-and-dump test using standard GHC options defined by the testsuite. +-- It takes two parameters: name of a file containing a test (no ".hs" +-- extension) and directory where the test is located (relative to +-- goldenPath). Test name and path are passed separately so that this function +-- can be used easily with testCompileAndDumpGroup. +compileAndDumpStdTest :: FilePath -> FilePath -> TestTree +compileAndDumpStdTest testName testPath = + compileAndDumpTest (testPath ++ (pathSeparator : testName)) ghcOpts + +-- A convenience function for defining a group of compile-and-dump tests stored +-- in the same subdirectory. It takes the name of subdirectory and list of +-- functions that given the name of subdirectory create a TestTree. Designed for +-- use with compileAndDumpStdTest. +testCompileAndDumpGroup :: FilePath -> [FilePath -> TestTree] -> TestTree +testCompileAndDumpGroup testDir tests = + testGroup testDir $ map ($ testDir) tests + +-- Note [Ignore exit code] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- It may happen that compilation of a source file fails. We could find out +-- whether that happened by inspecting the exit code of GHC process. But it +-- would be tricky to get a helpful message from the failing test: we would need +-- to display stderr which we just wrote into a file. Luckliy we don't have to +-- do that - we can ignore the problem here and let the test fail when the +-- actual file is compared with the golden file. + +-- Note [Diff options] +-- ~~~~~~~~~~~~~~~~~~~ +-- +-- We use following diff options: +-- -w - Ignore all white space. +-- -B - Ignore changes whose lines are all blank. + +-- Note [Normalization with sed] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Output file is normalized with sed. Line numbers generated in splices: +-- +-- Foo:(40,3)-(42,4) +-- Foo.hs:7:3: +-- Equals_1235967303 +-- +-- are turned into: +-- +-- Foo:(0,0)-(0,0) +-- Foo.hs:0:0: +-- Equals_0123456789 +-- +-- This allows to insert comments into test file without the need to modify the +-- golden file to adjust line numbers. +-- +-- Note that GNU sed (on Linux) and BSD sed (on MacOS) are slightly different. +-- We use conditional compilation to deal with this. + +filterWithSed :: FilePath -> IO () +filterWithSed file = runProcessWithOpts CreatePipe "sed" +#ifdef darwin_HOST_OS + [ "-i", "''" +#else + [ "-i" +#endif + , "-e", "'s/([0-9]*,[0-9]*)-([0-9]*,[0-9]*)/(0,0)-(0,0)/g'" + , "-e", "'s/:[0-9][0-9]*:[0-9][0-9]*/:0:0/g'" + , "-e", "'s/:[0-9]*:[0-9]*-[0-9]*/:0:0:/g'" + , "-e", "'s/[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]/0123456789/g'" + , file + ] + +buildGoldenFile :: FilePath -> FilePath -> IO () +buildGoldenFile templateFilePath goldenFilePath = do + hGoldenFile <- openFile goldenFilePath WriteMode + runProcessWithOpts (UseHandle hGoldenFile) "awk" + [ "-f", "tests/compile-and-dump/buildGoldenFiles.awk" + , templateFilePath + ] + +runProcessWithOpts :: StdStream -> String -> [String] -> IO () +runProcessWithOpts stdout program opts = do + (_, _, Just serr, pid) <- + createProcess (proc "bash" ["-c", (intercalate " " (program : opts))]) + { std_out = stdout + , std_err = CreatePipe } + ecode <- waitForProcess pid + case ecode of + ExitSuccess -> return () + ExitFailure _ -> do + err <- hGetContents serr -- Text would be faster than String, but this is + -- a corner case so probably not worth it. + throw $ ProcessException ("Error when running " ++ program ++ ":\n" ++ err) diff --git a/tests/compile-and-dump/GradingClient/Database.ghc76.template b/tests/compile-and-dump/GradingClient/Database.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/GradingClient/Database.ghc76.template @@ -0,0 +1,4470 @@ +GradingClient/Database.hs:0:0: Splicing declarations + singletons + [d| data Nat + = Zero | Succ Nat + deriving (Eq, Ord) |] + ======> + GradingClient/Database.hs:(0,0)-(0,0) + data Nat + = Zero | Succ Nat + deriving (Eq, Ord) + type instance (:==) Zero Zero = True + type instance (:==) Zero (Succ b) = False + type instance (:==) (Succ a) Zero = False + type instance (:==) (Succ a) (Succ b) = :== a b + data instance Sing (z :: Nat) + = z ~ Zero => SZero | + forall (n :: Nat). z ~ Succ n => SSucc (Sing n) + type SNat (z :: Nat) = Sing z + instance SingKind (KProxy :: KProxy Nat) where + type instance DemoteRep (KProxy :: KProxy Nat) = Nat + fromSing SZero = Zero + fromSing (SSucc b) = Succ (fromSing b) + toSing Zero = SomeSing SZero + toSing (Succ b) + = case toSing b :: SomeSing (KProxy :: KProxy Nat) of { + SomeSing c -> SomeSing (SSucc c) } + instance SEq (KProxy :: KProxy Nat) where + %:== SZero SZero = STrue + %:== SZero (SSucc _) = SFalse + %:== (SSucc _) SZero = SFalse + %:== (SSucc a) (SSucc b) = (%:==) a b + instance SDecide (KProxy :: KProxy Nat) where + %~ SZero SZero = Proved Refl + %~ SZero (SSucc _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SSucc _) SZero + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SSucc a) (SSucc b) + = case (%~) a b of { + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\ Refl -> contra Refl) } + instance SingI Zero where + sing = SZero + instance SingI n => SingI (Succ (n :: Nat)) where + sing = SSucc sing +GradingClient/Database.hs:0:0: Splicing declarations + singletons + [d| append :: Schema -> Schema -> Schema + append (Sch s1) (Sch s2) = Sch (s1 ++ s2) + attrNotIn :: Attribute -> Schema -> Bool + attrNotIn _ (Sch []) = True + attrNotIn (Attr name u) (Sch ((Attr name' _) : t)) + = (name /= name') && (attrNotIn (Attr name u) (Sch t)) + disjoint :: Schema -> Schema -> Bool + disjoint (Sch []) _ = True + disjoint (Sch (h : t)) s = (attrNotIn h s) && (disjoint (Sch t) s) + occurs :: [AChar] -> Schema -> Bool + occurs _ (Sch []) = False + occurs name (Sch ((Attr name' _) : attrs)) + = name == name' || occurs name (Sch attrs) + lookup :: [AChar] -> Schema -> U + lookup _ (Sch []) = undefined + lookup name (Sch ((Attr name' u) : attrs)) + = if name == name' then u else lookup name (Sch attrs) + + data U + = BOOL | STRING | NAT | VEC U Nat + deriving (Read, Eq, Show) + data AChar + = CA | + CB | + CC | + CD | + CE | + CF | + CG | + CH | + CI | + CJ | + CK | + CL | + CM | + CN | + CO | + CP | + CQ | + CR | + CS | + CT | + CU | + CV | + CW | + CX | + CY | + CZ + deriving (Read, Show, Eq) + data Attribute = Attr [AChar] U + data Schema = Sch [Attribute] |] + ======> + GradingClient/Database.hs:(0,0)-(0,0) + data U + = BOOL | STRING | NAT | VEC U Nat + deriving (Read, Eq, Show) + data AChar + = CA | + CB | + CC | + CD | + CE | + CF | + CG | + CH | + CI | + CJ | + CK | + CL | + CM | + CN | + CO | + CP | + CQ | + CR | + CS | + CT | + CU | + CV | + CW | + CX | + CY | + CZ + deriving (Read, Show, Eq) + data Attribute = Attr [AChar] U + data Schema = Sch [Attribute] + append :: Schema -> Schema -> Schema + append (Sch s1) (Sch s2) = Sch (s1 ++ s2) + attrNotIn :: Attribute -> Schema -> Bool + attrNotIn _ (Sch GHC.Types.[]) = True + attrNotIn (Attr name u) (Sch ((Attr name' _) GHC.Types.: t)) + = ((name /= name') && (attrNotIn (Attr name u) (Sch t))) + disjoint :: Schema -> Schema -> Bool + disjoint (Sch GHC.Types.[]) _ = True + disjoint (Sch (h GHC.Types.: t)) s + = ((attrNotIn h s) && (disjoint (Sch t) s)) + occurs :: [AChar] -> Schema -> Bool + occurs _ (Sch GHC.Types.[]) = False + occurs name (Sch ((Attr name' _) GHC.Types.: attrs)) + = ((name == name') || (occurs name (Sch attrs))) + lookup :: [AChar] -> Schema -> U + lookup _ (Sch GHC.Types.[]) = undefined + lookup name (Sch ((Attr name' u) GHC.Types.: attrs)) + = if (name == name') then u else lookup name (Sch attrs) + type instance (:==) BOOL BOOL = True + type instance (:==) BOOL STRING = False + type instance (:==) BOOL NAT = False + type instance (:==) BOOL (VEC b b) = False + type instance (:==) STRING BOOL = False + type instance (:==) STRING STRING = True + type instance (:==) STRING NAT = False + type instance (:==) STRING (VEC b b) = False + type instance (:==) NAT BOOL = False + type instance (:==) NAT STRING = False + type instance (:==) NAT NAT = True + type instance (:==) NAT (VEC b b) = False + type instance (:==) (VEC a a) BOOL = False + type instance (:==) (VEC a a) STRING = False + type instance (:==) (VEC a a) NAT = False + type instance (:==) (VEC a a) (VEC b b) = :&& (:== a b) (:== a b) + type instance (:==) CA CA = True + type instance (:==) CA CB = False + type instance (:==) CA CC = False + type instance (:==) CA CD = False + type instance (:==) CA CE = False + type instance (:==) CA CF = False + type instance (:==) CA CG = False + type instance (:==) CA CH = False + type instance (:==) CA CI = False + type instance (:==) CA CJ = False + type instance (:==) CA CK = False + type instance (:==) CA CL = False + type instance (:==) CA CM = False + type instance (:==) CA CN = False + type instance (:==) CA CO = False + type instance (:==) CA CP = False + type instance (:==) CA CQ = False + type instance (:==) CA CR = False + type instance (:==) CA CS = False + type instance (:==) CA CT = False + type instance (:==) CA CU = False + type instance (:==) CA CV = False + type instance (:==) CA CW = False + type instance (:==) CA CX = False + type instance (:==) CA CY = False + type instance (:==) CA CZ = False + type instance (:==) CB CA = False + type instance (:==) CB CB = True + type instance (:==) CB CC = False + type instance (:==) CB CD = False + type instance (:==) CB CE = False + type instance (:==) CB CF = False + type instance (:==) CB CG = False + type instance (:==) CB CH = False + type instance (:==) CB CI = False + type instance (:==) CB CJ = False + type instance (:==) CB CK = False + type instance (:==) CB CL = False + type instance (:==) CB CM = False + type instance (:==) CB CN = False + type instance (:==) CB CO = False + type instance (:==) CB CP = False + type instance (:==) CB CQ = False + type instance (:==) CB CR = False + type instance (:==) CB CS = False + type instance (:==) CB CT = False + type instance (:==) CB CU = False + type instance (:==) CB CV = False + type instance (:==) CB CW = False + type instance (:==) CB CX = False + type instance (:==) CB CY = False + type instance (:==) CB CZ = False + type instance (:==) CC CA = False + type instance (:==) CC CB = False + type instance (:==) CC CC = True + type instance (:==) CC CD = False + type instance (:==) CC CE = False + type instance (:==) CC CF = False + type instance (:==) CC CG = False + type instance (:==) CC CH = False + type instance (:==) CC CI = False + type instance (:==) CC CJ = False + type instance (:==) CC CK = False + type instance (:==) CC CL = False + type instance (:==) CC CM = False + type instance (:==) CC CN = False + type instance (:==) CC CO = False + type instance (:==) CC CP = False + type instance (:==) CC CQ = False + type instance (:==) CC CR = False + type instance (:==) CC CS = False + type instance (:==) CC CT = False + type instance (:==) CC CU = False + type instance (:==) CC CV = False + type instance (:==) CC CW = False + type instance (:==) CC CX = False + type instance (:==) CC CY = False + type instance (:==) CC CZ = False + type instance (:==) CD CA = False + type instance (:==) CD CB = False + type instance (:==) CD CC = False + type instance (:==) CD CD = True + type instance (:==) CD CE = False + type instance (:==) CD CF = False + type instance (:==) CD CG = False + type instance (:==) CD CH = False + type instance (:==) CD CI = False + type instance (:==) CD CJ = False + type instance (:==) CD CK = False + type instance (:==) CD CL = False + type instance (:==) CD CM = False + type instance (:==) CD CN = False + type instance (:==) CD CO = False + type instance (:==) CD CP = False + type instance (:==) CD CQ = False + type instance (:==) CD CR = False + type instance (:==) CD CS = False + type instance (:==) CD CT = False + type instance (:==) CD CU = False + type instance (:==) CD CV = False + type instance (:==) CD CW = False + type instance (:==) CD CX = False + type instance (:==) CD CY = False + type instance (:==) CD CZ = False + type instance (:==) CE CA = False + type instance (:==) CE CB = False + type instance (:==) CE CC = False + type instance (:==) CE CD = False + type instance (:==) CE CE = True + type instance (:==) CE CF = False + type instance (:==) CE CG = False + type instance (:==) CE CH = False + type instance (:==) CE CI = False + type instance (:==) CE CJ = False + type instance (:==) CE CK = False + type instance (:==) CE CL = False + type instance (:==) CE CM = False + type instance (:==) CE CN = False + type instance (:==) CE CO = False + type instance (:==) CE CP = False + type instance (:==) CE CQ = False + type instance (:==) CE CR = False + type instance (:==) CE CS = False + type instance (:==) CE CT = False + type instance (:==) CE CU = False + type instance (:==) CE CV = False + type instance (:==) CE CW = False + type instance (:==) CE CX = False + type instance (:==) CE CY = False + type instance (:==) CE CZ = False + type instance (:==) CF CA = False + type instance (:==) CF CB = False + type instance (:==) CF CC = False + type instance (:==) CF CD = False + type instance (:==) CF CE = False + type instance (:==) CF CF = True + type instance (:==) CF CG = False + type instance (:==) CF CH = False + type instance (:==) CF CI = False + type instance (:==) CF CJ = False + type instance (:==) CF CK = False + type instance (:==) CF CL = False + type instance (:==) CF CM = False + type instance (:==) CF CN = False + type instance (:==) CF CO = False + type instance (:==) CF CP = False + type instance (:==) CF CQ = False + type instance (:==) CF CR = False + type instance (:==) CF CS = False + type instance (:==) CF CT = False + type instance (:==) CF CU = False + type instance (:==) CF CV = False + type instance (:==) CF CW = False + type instance (:==) CF CX = False + type instance (:==) CF CY = False + type instance (:==) CF CZ = False + type instance (:==) CG CA = False + type instance (:==) CG CB = False + type instance (:==) CG CC = False + type instance (:==) CG CD = False + type instance (:==) CG CE = False + type instance (:==) CG CF = False + type instance (:==) CG CG = True + type instance (:==) CG CH = False + type instance (:==) CG CI = False + type instance (:==) CG CJ = False + type instance (:==) CG CK = False + type instance (:==) CG CL = False + type instance (:==) CG CM = False + type instance (:==) CG CN = False + type instance (:==) CG CO = False + type instance (:==) CG CP = False + type instance (:==) CG CQ = False + type instance (:==) CG CR = False + type instance (:==) CG CS = False + type instance (:==) CG CT = False + type instance (:==) CG CU = False + type instance (:==) CG CV = False + type instance (:==) CG CW = False + type instance (:==) CG CX = False + type instance (:==) CG CY = False + type instance (:==) CG CZ = False + type instance (:==) CH CA = False + type instance (:==) CH CB = False + type instance (:==) CH CC = False + type instance (:==) CH CD = False + type instance (:==) CH CE = False + type instance (:==) CH CF = False + type instance (:==) CH CG = False + type instance (:==) CH CH = True + type instance (:==) CH CI = False + type instance (:==) CH CJ = False + type instance (:==) CH CK = False + type instance (:==) CH CL = False + type instance (:==) CH CM = False + type instance (:==) CH CN = False + type instance (:==) CH CO = False + type instance (:==) CH CP = False + type instance (:==) CH CQ = False + type instance (:==) CH CR = False + type instance (:==) CH CS = False + type instance (:==) CH CT = False + type instance (:==) CH CU = False + type instance (:==) CH CV = False + type instance (:==) CH CW = False + type instance (:==) CH CX = False + type instance (:==) CH CY = False + type instance (:==) CH CZ = False + type instance (:==) CI CA = False + type instance (:==) CI CB = False + type instance (:==) CI CC = False + type instance (:==) CI CD = False + type instance (:==) CI CE = False + type instance (:==) CI CF = False + type instance (:==) CI CG = False + type instance (:==) CI CH = False + type instance (:==) CI CI = True + type instance (:==) CI CJ = False + type instance (:==) CI CK = False + type instance (:==) CI CL = False + type instance (:==) CI CM = False + type instance (:==) CI CN = False + type instance (:==) CI CO = False + type instance (:==) CI CP = False + type instance (:==) CI CQ = False + type instance (:==) CI CR = False + type instance (:==) CI CS = False + type instance (:==) CI CT = False + type instance (:==) CI CU = False + type instance (:==) CI CV = False + type instance (:==) CI CW = False + type instance (:==) CI CX = False + type instance (:==) CI CY = False + type instance (:==) CI CZ = False + type instance (:==) CJ CA = False + type instance (:==) CJ CB = False + type instance (:==) CJ CC = False + type instance (:==) CJ CD = False + type instance (:==) CJ CE = False + type instance (:==) CJ CF = False + type instance (:==) CJ CG = False + type instance (:==) CJ CH = False + type instance (:==) CJ CI = False + type instance (:==) CJ CJ = True + type instance (:==) CJ CK = False + type instance (:==) CJ CL = False + type instance (:==) CJ CM = False + type instance (:==) CJ CN = False + type instance (:==) CJ CO = False + type instance (:==) CJ CP = False + type instance (:==) CJ CQ = False + type instance (:==) CJ CR = False + type instance (:==) CJ CS = False + type instance (:==) CJ CT = False + type instance (:==) CJ CU = False + type instance (:==) CJ CV = False + type instance (:==) CJ CW = False + type instance (:==) CJ CX = False + type instance (:==) CJ CY = False + type instance (:==) CJ CZ = False + type instance (:==) CK CA = False + type instance (:==) CK CB = False + type instance (:==) CK CC = False + type instance (:==) CK CD = False + type instance (:==) CK CE = False + type instance (:==) CK CF = False + type instance (:==) CK CG = False + type instance (:==) CK CH = False + type instance (:==) CK CI = False + type instance (:==) CK CJ = False + type instance (:==) CK CK = True + type instance (:==) CK CL = False + type instance (:==) CK CM = False + type instance (:==) CK CN = False + type instance (:==) CK CO = False + type instance (:==) CK CP = False + type instance (:==) CK CQ = False + type instance (:==) CK CR = False + type instance (:==) CK CS = False + type instance (:==) CK CT = False + type instance (:==) CK CU = False + type instance (:==) CK CV = False + type instance (:==) CK CW = False + type instance (:==) CK CX = False + type instance (:==) CK CY = False + type instance (:==) CK CZ = False + type instance (:==) CL CA = False + type instance (:==) CL CB = False + type instance (:==) CL CC = False + type instance (:==) CL CD = False + type instance (:==) CL CE = False + type instance (:==) CL CF = False + type instance (:==) CL CG = False + type instance (:==) CL CH = False + type instance (:==) CL CI = False + type instance (:==) CL CJ = False + type instance (:==) CL CK = False + type instance (:==) CL CL = True + type instance (:==) CL CM = False + type instance (:==) CL CN = False + type instance (:==) CL CO = False + type instance (:==) CL CP = False + type instance (:==) CL CQ = False + type instance (:==) CL CR = False + type instance (:==) CL CS = False + type instance (:==) CL CT = False + type instance (:==) CL CU = False + type instance (:==) CL CV = False + type instance (:==) CL CW = False + type instance (:==) CL CX = False + type instance (:==) CL CY = False + type instance (:==) CL CZ = False + type instance (:==) CM CA = False + type instance (:==) CM CB = False + type instance (:==) CM CC = False + type instance (:==) CM CD = False + type instance (:==) CM CE = False + type instance (:==) CM CF = False + type instance (:==) CM CG = False + type instance (:==) CM CH = False + type instance (:==) CM CI = False + type instance (:==) CM CJ = False + type instance (:==) CM CK = False + type instance (:==) CM CL = False + type instance (:==) CM CM = True + type instance (:==) CM CN = False + type instance (:==) CM CO = False + type instance (:==) CM CP = False + type instance (:==) CM CQ = False + type instance (:==) CM CR = False + type instance (:==) CM CS = False + type instance (:==) CM CT = False + type instance (:==) CM CU = False + type instance (:==) CM CV = False + type instance (:==) CM CW = False + type instance (:==) CM CX = False + type instance (:==) CM CY = False + type instance (:==) CM CZ = False + type instance (:==) CN CA = False + type instance (:==) CN CB = False + type instance (:==) CN CC = False + type instance (:==) CN CD = False + type instance (:==) CN CE = False + type instance (:==) CN CF = False + type instance (:==) CN CG = False + type instance (:==) CN CH = False + type instance (:==) CN CI = False + type instance (:==) CN CJ = False + type instance (:==) CN CK = False + type instance (:==) CN CL = False + type instance (:==) CN CM = False + type instance (:==) CN CN = True + type instance (:==) CN CO = False + type instance (:==) CN CP = False + type instance (:==) CN CQ = False + type instance (:==) CN CR = False + type instance (:==) CN CS = False + type instance (:==) CN CT = False + type instance (:==) CN CU = False + type instance (:==) CN CV = False + type instance (:==) CN CW = False + type instance (:==) CN CX = False + type instance (:==) CN CY = False + type instance (:==) CN CZ = False + type instance (:==) CO CA = False + type instance (:==) CO CB = False + type instance (:==) CO CC = False + type instance (:==) CO CD = False + type instance (:==) CO CE = False + type instance (:==) CO CF = False + type instance (:==) CO CG = False + type instance (:==) CO CH = False + type instance (:==) CO CI = False + type instance (:==) CO CJ = False + type instance (:==) CO CK = False + type instance (:==) CO CL = False + type instance (:==) CO CM = False + type instance (:==) CO CN = False + type instance (:==) CO CO = True + type instance (:==) CO CP = False + type instance (:==) CO CQ = False + type instance (:==) CO CR = False + type instance (:==) CO CS = False + type instance (:==) CO CT = False + type instance (:==) CO CU = False + type instance (:==) CO CV = False + type instance (:==) CO CW = False + type instance (:==) CO CX = False + type instance (:==) CO CY = False + type instance (:==) CO CZ = False + type instance (:==) CP CA = False + type instance (:==) CP CB = False + type instance (:==) CP CC = False + type instance (:==) CP CD = False + type instance (:==) CP CE = False + type instance (:==) CP CF = False + type instance (:==) CP CG = False + type instance (:==) CP CH = False + type instance (:==) CP CI = False + type instance (:==) CP CJ = False + type instance (:==) CP CK = False + type instance (:==) CP CL = False + type instance (:==) CP CM = False + type instance (:==) CP CN = False + type instance (:==) CP CO = False + type instance (:==) CP CP = True + type instance (:==) CP CQ = False + type instance (:==) CP CR = False + type instance (:==) CP CS = False + type instance (:==) CP CT = False + type instance (:==) CP CU = False + type instance (:==) CP CV = False + type instance (:==) CP CW = False + type instance (:==) CP CX = False + type instance (:==) CP CY = False + type instance (:==) CP CZ = False + type instance (:==) CQ CA = False + type instance (:==) CQ CB = False + type instance (:==) CQ CC = False + type instance (:==) CQ CD = False + type instance (:==) CQ CE = False + type instance (:==) CQ CF = False + type instance (:==) CQ CG = False + type instance (:==) CQ CH = False + type instance (:==) CQ CI = False + type instance (:==) CQ CJ = False + type instance (:==) CQ CK = False + type instance (:==) CQ CL = False + type instance (:==) CQ CM = False + type instance (:==) CQ CN = False + type instance (:==) CQ CO = False + type instance (:==) CQ CP = False + type instance (:==) CQ CQ = True + type instance (:==) CQ CR = False + type instance (:==) CQ CS = False + type instance (:==) CQ CT = False + type instance (:==) CQ CU = False + type instance (:==) CQ CV = False + type instance (:==) CQ CW = False + type instance (:==) CQ CX = False + type instance (:==) CQ CY = False + type instance (:==) CQ CZ = False + type instance (:==) CR CA = False + type instance (:==) CR CB = False + type instance (:==) CR CC = False + type instance (:==) CR CD = False + type instance (:==) CR CE = False + type instance (:==) CR CF = False + type instance (:==) CR CG = False + type instance (:==) CR CH = False + type instance (:==) CR CI = False + type instance (:==) CR CJ = False + type instance (:==) CR CK = False + type instance (:==) CR CL = False + type instance (:==) CR CM = False + type instance (:==) CR CN = False + type instance (:==) CR CO = False + type instance (:==) CR CP = False + type instance (:==) CR CQ = False + type instance (:==) CR CR = True + type instance (:==) CR CS = False + type instance (:==) CR CT = False + type instance (:==) CR CU = False + type instance (:==) CR CV = False + type instance (:==) CR CW = False + type instance (:==) CR CX = False + type instance (:==) CR CY = False + type instance (:==) CR CZ = False + type instance (:==) CS CA = False + type instance (:==) CS CB = False + type instance (:==) CS CC = False + type instance (:==) CS CD = False + type instance (:==) CS CE = False + type instance (:==) CS CF = False + type instance (:==) CS CG = False + type instance (:==) CS CH = False + type instance (:==) CS CI = False + type instance (:==) CS CJ = False + type instance (:==) CS CK = False + type instance (:==) CS CL = False + type instance (:==) CS CM = False + type instance (:==) CS CN = False + type instance (:==) CS CO = False + type instance (:==) CS CP = False + type instance (:==) CS CQ = False + type instance (:==) CS CR = False + type instance (:==) CS CS = True + type instance (:==) CS CT = False + type instance (:==) CS CU = False + type instance (:==) CS CV = False + type instance (:==) CS CW = False + type instance (:==) CS CX = False + type instance (:==) CS CY = False + type instance (:==) CS CZ = False + type instance (:==) CT CA = False + type instance (:==) CT CB = False + type instance (:==) CT CC = False + type instance (:==) CT CD = False + type instance (:==) CT CE = False + type instance (:==) CT CF = False + type instance (:==) CT CG = False + type instance (:==) CT CH = False + type instance (:==) CT CI = False + type instance (:==) CT CJ = False + type instance (:==) CT CK = False + type instance (:==) CT CL = False + type instance (:==) CT CM = False + type instance (:==) CT CN = False + type instance (:==) CT CO = False + type instance (:==) CT CP = False + type instance (:==) CT CQ = False + type instance (:==) CT CR = False + type instance (:==) CT CS = False + type instance (:==) CT CT = True + type instance (:==) CT CU = False + type instance (:==) CT CV = False + type instance (:==) CT CW = False + type instance (:==) CT CX = False + type instance (:==) CT CY = False + type instance (:==) CT CZ = False + type instance (:==) CU CA = False + type instance (:==) CU CB = False + type instance (:==) CU CC = False + type instance (:==) CU CD = False + type instance (:==) CU CE = False + type instance (:==) CU CF = False + type instance (:==) CU CG = False + type instance (:==) CU CH = False + type instance (:==) CU CI = False + type instance (:==) CU CJ = False + type instance (:==) CU CK = False + type instance (:==) CU CL = False + type instance (:==) CU CM = False + type instance (:==) CU CN = False + type instance (:==) CU CO = False + type instance (:==) CU CP = False + type instance (:==) CU CQ = False + type instance (:==) CU CR = False + type instance (:==) CU CS = False + type instance (:==) CU CT = False + type instance (:==) CU CU = True + type instance (:==) CU CV = False + type instance (:==) CU CW = False + type instance (:==) CU CX = False + type instance (:==) CU CY = False + type instance (:==) CU CZ = False + type instance (:==) CV CA = False + type instance (:==) CV CB = False + type instance (:==) CV CC = False + type instance (:==) CV CD = False + type instance (:==) CV CE = False + type instance (:==) CV CF = False + type instance (:==) CV CG = False + type instance (:==) CV CH = False + type instance (:==) CV CI = False + type instance (:==) CV CJ = False + type instance (:==) CV CK = False + type instance (:==) CV CL = False + type instance (:==) CV CM = False + type instance (:==) CV CN = False + type instance (:==) CV CO = False + type instance (:==) CV CP = False + type instance (:==) CV CQ = False + type instance (:==) CV CR = False + type instance (:==) CV CS = False + type instance (:==) CV CT = False + type instance (:==) CV CU = False + type instance (:==) CV CV = True + type instance (:==) CV CW = False + type instance (:==) CV CX = False + type instance (:==) CV CY = False + type instance (:==) CV CZ = False + type instance (:==) CW CA = False + type instance (:==) CW CB = False + type instance (:==) CW CC = False + type instance (:==) CW CD = False + type instance (:==) CW CE = False + type instance (:==) CW CF = False + type instance (:==) CW CG = False + type instance (:==) CW CH = False + type instance (:==) CW CI = False + type instance (:==) CW CJ = False + type instance (:==) CW CK = False + type instance (:==) CW CL = False + type instance (:==) CW CM = False + type instance (:==) CW CN = False + type instance (:==) CW CO = False + type instance (:==) CW CP = False + type instance (:==) CW CQ = False + type instance (:==) CW CR = False + type instance (:==) CW CS = False + type instance (:==) CW CT = False + type instance (:==) CW CU = False + type instance (:==) CW CV = False + type instance (:==) CW CW = True + type instance (:==) CW CX = False + type instance (:==) CW CY = False + type instance (:==) CW CZ = False + type instance (:==) CX CA = False + type instance (:==) CX CB = False + type instance (:==) CX CC = False + type instance (:==) CX CD = False + type instance (:==) CX CE = False + type instance (:==) CX CF = False + type instance (:==) CX CG = False + type instance (:==) CX CH = False + type instance (:==) CX CI = False + type instance (:==) CX CJ = False + type instance (:==) CX CK = False + type instance (:==) CX CL = False + type instance (:==) CX CM = False + type instance (:==) CX CN = False + type instance (:==) CX CO = False + type instance (:==) CX CP = False + type instance (:==) CX CQ = False + type instance (:==) CX CR = False + type instance (:==) CX CS = False + type instance (:==) CX CT = False + type instance (:==) CX CU = False + type instance (:==) CX CV = False + type instance (:==) CX CW = False + type instance (:==) CX CX = True + type instance (:==) CX CY = False + type instance (:==) CX CZ = False + type instance (:==) CY CA = False + type instance (:==) CY CB = False + type instance (:==) CY CC = False + type instance (:==) CY CD = False + type instance (:==) CY CE = False + type instance (:==) CY CF = False + type instance (:==) CY CG = False + type instance (:==) CY CH = False + type instance (:==) CY CI = False + type instance (:==) CY CJ = False + type instance (:==) CY CK = False + type instance (:==) CY CL = False + type instance (:==) CY CM = False + type instance (:==) CY CN = False + type instance (:==) CY CO = False + type instance (:==) CY CP = False + type instance (:==) CY CQ = False + type instance (:==) CY CR = False + type instance (:==) CY CS = False + type instance (:==) CY CT = False + type instance (:==) CY CU = False + type instance (:==) CY CV = False + type instance (:==) CY CW = False + type instance (:==) CY CX = False + type instance (:==) CY CY = True + type instance (:==) CY CZ = False + type instance (:==) CZ CA = False + type instance (:==) CZ CB = False + type instance (:==) CZ CC = False + type instance (:==) CZ CD = False + type instance (:==) CZ CE = False + type instance (:==) CZ CF = False + type instance (:==) CZ CG = False + type instance (:==) CZ CH = False + type instance (:==) CZ CI = False + type instance (:==) CZ CJ = False + type instance (:==) CZ CK = False + type instance (:==) CZ CL = False + type instance (:==) CZ CM = False + type instance (:==) CZ CN = False + type instance (:==) CZ CO = False + type instance (:==) CZ CP = False + type instance (:==) CZ CQ = False + type instance (:==) CZ CR = False + type instance (:==) CZ CS = False + type instance (:==) CZ CT = False + type instance (:==) CZ CU = False + type instance (:==) CZ CV = False + type instance (:==) CZ CW = False + type instance (:==) CZ CX = False + type instance (:==) CZ CY = False + type instance (:==) CZ CZ = True + type instance Append (Sch s1) (Sch s2) = Sch (:++ s1 s2) + type instance AttrNotIn z (Sch GHC.Types.[]) = True + type instance AttrNotIn (Attr name u) (Sch (GHC.Types.: (Attr name' z) t)) = + :&& (:/= name name') (AttrNotIn (Attr name u) (Sch t)) + type instance Disjoint (Sch GHC.Types.[]) z = True + type instance Disjoint (Sch (GHC.Types.: h t)) s = + :&& (AttrNotIn h s) (Disjoint (Sch t) s) + type instance Occurs z (Sch GHC.Types.[]) = False + type instance Occurs name (Sch (GHC.Types.: (Attr name' z) attrs)) = + :|| (:== name name') (Occurs name (Sch attrs)) + type instance Lookup z (Sch GHC.Types.[]) = Any + type instance Lookup name (Sch (GHC.Types.: (Attr name' u) attrs)) = + If (:== name name') u (Lookup name (Sch attrs)) + type family Append (a :: Schema) (a :: Schema) :: Schema + type family AttrNotIn (a :: Attribute) (a :: Schema) :: Bool + type family Disjoint (a :: Schema) (a :: Schema) :: Bool + type family Occurs (a :: [AChar]) (a :: Schema) :: Bool + type family Lookup (a :: [AChar]) (a :: Schema) :: U + data instance Sing (z :: U) + = z ~ BOOL => SBOOL | + z ~ STRING => SSTRING | + z ~ NAT => SNAT | + forall (n :: U) (n :: Nat). z ~ VEC n n => SVEC (Sing n) (Sing n) + type SU (z :: U) = Sing z + instance SingKind (KProxy :: KProxy U) where + type instance DemoteRep (KProxy :: KProxy U) = U + fromSing SBOOL = BOOL + fromSing SSTRING = STRING + fromSing SNAT = NAT + fromSing (SVEC b b) = VEC (fromSing b) (fromSing b) + toSing BOOL = SomeSing SBOOL + toSing STRING = SomeSing SSTRING + toSing NAT = SomeSing SNAT + toSing (VEC b b) + = case + (toSing b :: SomeSing (KProxy :: KProxy U), + toSing b :: SomeSing (KProxy :: KProxy Nat)) + of { + (SomeSing c, SomeSing c) -> SomeSing (SVEC c c) } + instance SEq (KProxy :: KProxy U) where + %:== SBOOL SBOOL = STrue + %:== SBOOL SSTRING = SFalse + %:== SBOOL SNAT = SFalse + %:== SBOOL (SVEC _ _) = SFalse + %:== SSTRING SBOOL = SFalse + %:== SSTRING SSTRING = STrue + %:== SSTRING SNAT = SFalse + %:== SSTRING (SVEC _ _) = SFalse + %:== SNAT SBOOL = SFalse + %:== SNAT SSTRING = SFalse + %:== SNAT SNAT = STrue + %:== SNAT (SVEC _ _) = SFalse + %:== (SVEC _ _) SBOOL = SFalse + %:== (SVEC _ _) SSTRING = SFalse + %:== (SVEC _ _) SNAT = SFalse + %:== (SVEC a a) (SVEC b b) = (%:&&) ((%:==) a b) ((%:==) a b) + instance SDecide (KProxy :: KProxy U) where + %~ SBOOL SBOOL = Proved Refl + %~ SBOOL SSTRING + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SBOOL SNAT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SBOOL (SVEC _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SSTRING SBOOL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SSTRING SSTRING = Proved Refl + %~ SSTRING SNAT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SSTRING (SVEC _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SNAT SBOOL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SNAT SSTRING + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SNAT SNAT = Proved Refl + %~ SNAT (SVEC _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SVEC _ _) SBOOL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SVEC _ _) SSTRING + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SVEC _ _) SNAT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SVEC a a) (SVEC b b) + = case ((%~) a b, (%~) a b) of { + (Proved Refl, Proved Refl) -> Proved Refl + (Disproved contra, _) -> Disproved (\ Refl -> contra Refl) + (_, Disproved contra) -> Disproved (\ Refl -> contra Refl) } + instance SingI BOOL where + sing = SBOOL + instance SingI STRING where + sing = SSTRING + instance SingI NAT where + sing = SNAT + instance (SingI n, SingI n) => + SingI (VEC (n :: U) (n :: Nat)) where + sing = SVEC sing sing + data instance Sing (z :: AChar) + = z ~ CA => SCA | + z ~ CB => SCB | + z ~ CC => SCC | + z ~ CD => SCD | + z ~ CE => SCE | + z ~ CF => SCF | + z ~ CG => SCG | + z ~ CH => SCH | + z ~ CI => SCI | + z ~ CJ => SCJ | + z ~ CK => SCK | + z ~ CL => SCL | + z ~ CM => SCM | + z ~ CN => SCN | + z ~ CO => SCO | + z ~ CP => SCP | + z ~ CQ => SCQ | + z ~ CR => SCR | + z ~ CS => SCS | + z ~ CT => SCT | + z ~ CU => SCU | + z ~ CV => SCV | + z ~ CW => SCW | + z ~ CX => SCX | + z ~ CY => SCY | + z ~ CZ => SCZ + type SAChar (z :: AChar) = Sing z + instance SingKind (KProxy :: KProxy AChar) where + type instance DemoteRep (KProxy :: KProxy AChar) = AChar + fromSing SCA = CA + fromSing SCB = CB + fromSing SCC = CC + fromSing SCD = CD + fromSing SCE = CE + fromSing SCF = CF + fromSing SCG = CG + fromSing SCH = CH + fromSing SCI = CI + fromSing SCJ = CJ + fromSing SCK = CK + fromSing SCL = CL + fromSing SCM = CM + fromSing SCN = CN + fromSing SCO = CO + fromSing SCP = CP + fromSing SCQ = CQ + fromSing SCR = CR + fromSing SCS = CS + fromSing SCT = CT + fromSing SCU = CU + fromSing SCV = CV + fromSing SCW = CW + fromSing SCX = CX + fromSing SCY = CY + fromSing SCZ = CZ + toSing CA = SomeSing SCA + toSing CB = SomeSing SCB + toSing CC = SomeSing SCC + toSing CD = SomeSing SCD + toSing CE = SomeSing SCE + toSing CF = SomeSing SCF + toSing CG = SomeSing SCG + toSing CH = SomeSing SCH + toSing CI = SomeSing SCI + toSing CJ = SomeSing SCJ + toSing CK = SomeSing SCK + toSing CL = SomeSing SCL + toSing CM = SomeSing SCM + toSing CN = SomeSing SCN + toSing CO = SomeSing SCO + toSing CP = SomeSing SCP + toSing CQ = SomeSing SCQ + toSing CR = SomeSing SCR + toSing CS = SomeSing SCS + toSing CT = SomeSing SCT + toSing CU = SomeSing SCU + toSing CV = SomeSing SCV + toSing CW = SomeSing SCW + toSing CX = SomeSing SCX + toSing CY = SomeSing SCY + toSing CZ = SomeSing SCZ + instance SEq (KProxy :: KProxy AChar) where + %:== SCA SCA = STrue + %:== SCA SCB = SFalse + %:== SCA SCC = SFalse + %:== SCA SCD = SFalse + %:== SCA SCE = SFalse + %:== SCA SCF = SFalse + %:== SCA SCG = SFalse + %:== SCA SCH = SFalse + %:== SCA SCI = SFalse + %:== SCA SCJ = SFalse + %:== SCA SCK = SFalse + %:== SCA SCL = SFalse + %:== SCA SCM = SFalse + %:== SCA SCN = SFalse + %:== SCA SCO = SFalse + %:== SCA SCP = SFalse + %:== SCA SCQ = SFalse + %:== SCA SCR = SFalse + %:== SCA SCS = SFalse + %:== SCA SCT = SFalse + %:== SCA SCU = SFalse + %:== SCA SCV = SFalse + %:== SCA SCW = SFalse + %:== SCA SCX = SFalse + %:== SCA SCY = SFalse + %:== SCA SCZ = SFalse + %:== SCB SCA = SFalse + %:== SCB SCB = STrue + %:== SCB SCC = SFalse + %:== SCB SCD = SFalse + %:== SCB SCE = SFalse + %:== SCB SCF = SFalse + %:== SCB SCG = SFalse + %:== SCB SCH = SFalse + %:== SCB SCI = SFalse + %:== SCB SCJ = SFalse + %:== SCB SCK = SFalse + %:== SCB SCL = SFalse + %:== SCB SCM = SFalse + %:== SCB SCN = SFalse + %:== SCB SCO = SFalse + %:== SCB SCP = SFalse + %:== SCB SCQ = SFalse + %:== SCB SCR = SFalse + %:== SCB SCS = SFalse + %:== SCB SCT = SFalse + %:== SCB SCU = SFalse + %:== SCB SCV = SFalse + %:== SCB SCW = SFalse + %:== SCB SCX = SFalse + %:== SCB SCY = SFalse + %:== SCB SCZ = SFalse + %:== SCC SCA = SFalse + %:== SCC SCB = SFalse + %:== SCC SCC = STrue + %:== SCC SCD = SFalse + %:== SCC SCE = SFalse + %:== SCC SCF = SFalse + %:== SCC SCG = SFalse + %:== SCC SCH = SFalse + %:== SCC SCI = SFalse + %:== SCC SCJ = SFalse + %:== SCC SCK = SFalse + %:== SCC SCL = SFalse + %:== SCC SCM = SFalse + %:== SCC SCN = SFalse + %:== SCC SCO = SFalse + %:== SCC SCP = SFalse + %:== SCC SCQ = SFalse + %:== SCC SCR = SFalse + %:== SCC SCS = SFalse + %:== SCC SCT = SFalse + %:== SCC SCU = SFalse + %:== SCC SCV = SFalse + %:== SCC SCW = SFalse + %:== SCC SCX = SFalse + %:== SCC SCY = SFalse + %:== SCC SCZ = SFalse + %:== SCD SCA = SFalse + %:== SCD SCB = SFalse + %:== SCD SCC = SFalse + %:== SCD SCD = STrue + %:== SCD SCE = SFalse + %:== SCD SCF = SFalse + %:== SCD SCG = SFalse + %:== SCD SCH = SFalse + %:== SCD SCI = SFalse + %:== SCD SCJ = SFalse + %:== SCD SCK = SFalse + %:== SCD SCL = SFalse + %:== SCD SCM = SFalse + %:== SCD SCN = SFalse + %:== SCD SCO = SFalse + %:== SCD SCP = SFalse + %:== SCD SCQ = SFalse + %:== SCD SCR = SFalse + %:== SCD SCS = SFalse + %:== SCD SCT = SFalse + %:== SCD SCU = SFalse + %:== SCD SCV = SFalse + %:== SCD SCW = SFalse + %:== SCD SCX = SFalse + %:== SCD SCY = SFalse + %:== SCD SCZ = SFalse + %:== SCE SCA = SFalse + %:== SCE SCB = SFalse + %:== SCE SCC = SFalse + %:== SCE SCD = SFalse + %:== SCE SCE = STrue + %:== SCE SCF = SFalse + %:== SCE SCG = SFalse + %:== SCE SCH = SFalse + %:== SCE SCI = SFalse + %:== SCE SCJ = SFalse + %:== SCE SCK = SFalse + %:== SCE SCL = SFalse + %:== SCE SCM = SFalse + %:== SCE SCN = SFalse + %:== SCE SCO = SFalse + %:== SCE SCP = SFalse + %:== SCE SCQ = SFalse + %:== SCE SCR = SFalse + %:== SCE SCS = SFalse + %:== SCE SCT = SFalse + %:== SCE SCU = SFalse + %:== SCE SCV = SFalse + %:== SCE SCW = SFalse + %:== SCE SCX = SFalse + %:== SCE SCY = SFalse + %:== SCE SCZ = SFalse + %:== SCF SCA = SFalse + %:== SCF SCB = SFalse + %:== SCF SCC = SFalse + %:== SCF SCD = SFalse + %:== SCF SCE = SFalse + %:== SCF SCF = STrue + %:== SCF SCG = SFalse + %:== SCF SCH = SFalse + %:== SCF SCI = SFalse + %:== SCF SCJ = SFalse + %:== SCF SCK = SFalse + %:== SCF SCL = SFalse + %:== SCF SCM = SFalse + %:== SCF SCN = SFalse + %:== SCF SCO = SFalse + %:== SCF SCP = SFalse + %:== SCF SCQ = SFalse + %:== SCF SCR = SFalse + %:== SCF SCS = SFalse + %:== SCF SCT = SFalse + %:== SCF SCU = SFalse + %:== SCF SCV = SFalse + %:== SCF SCW = SFalse + %:== SCF SCX = SFalse + %:== SCF SCY = SFalse + %:== SCF SCZ = SFalse + %:== SCG SCA = SFalse + %:== SCG SCB = SFalse + %:== SCG SCC = SFalse + %:== SCG SCD = SFalse + %:== SCG SCE = SFalse + %:== SCG SCF = SFalse + %:== SCG SCG = STrue + %:== SCG SCH = SFalse + %:== SCG SCI = SFalse + %:== SCG SCJ = SFalse + %:== SCG SCK = SFalse + %:== SCG SCL = SFalse + %:== SCG SCM = SFalse + %:== SCG SCN = SFalse + %:== SCG SCO = SFalse + %:== SCG SCP = SFalse + %:== SCG SCQ = SFalse + %:== SCG SCR = SFalse + %:== SCG SCS = SFalse + %:== SCG SCT = SFalse + %:== SCG SCU = SFalse + %:== SCG SCV = SFalse + %:== SCG SCW = SFalse + %:== SCG SCX = SFalse + %:== SCG SCY = SFalse + %:== SCG SCZ = SFalse + %:== SCH SCA = SFalse + %:== SCH SCB = SFalse + %:== SCH SCC = SFalse + %:== SCH SCD = SFalse + %:== SCH SCE = SFalse + %:== SCH SCF = SFalse + %:== SCH SCG = SFalse + %:== SCH SCH = STrue + %:== SCH SCI = SFalse + %:== SCH SCJ = SFalse + %:== SCH SCK = SFalse + %:== SCH SCL = SFalse + %:== SCH SCM = SFalse + %:== SCH SCN = SFalse + %:== SCH SCO = SFalse + %:== SCH SCP = SFalse + %:== SCH SCQ = SFalse + %:== SCH SCR = SFalse + %:== SCH SCS = SFalse + %:== SCH SCT = SFalse + %:== SCH SCU = SFalse + %:== SCH SCV = SFalse + %:== SCH SCW = SFalse + %:== SCH SCX = SFalse + %:== SCH SCY = SFalse + %:== SCH SCZ = SFalse + %:== SCI SCA = SFalse + %:== SCI SCB = SFalse + %:== SCI SCC = SFalse + %:== SCI SCD = SFalse + %:== SCI SCE = SFalse + %:== SCI SCF = SFalse + %:== SCI SCG = SFalse + %:== SCI SCH = SFalse + %:== SCI SCI = STrue + %:== SCI SCJ = SFalse + %:== SCI SCK = SFalse + %:== SCI SCL = SFalse + %:== SCI SCM = SFalse + %:== SCI SCN = SFalse + %:== SCI SCO = SFalse + %:== SCI SCP = SFalse + %:== SCI SCQ = SFalse + %:== SCI SCR = SFalse + %:== SCI SCS = SFalse + %:== SCI SCT = SFalse + %:== SCI SCU = SFalse + %:== SCI SCV = SFalse + %:== SCI SCW = SFalse + %:== SCI SCX = SFalse + %:== SCI SCY = SFalse + %:== SCI SCZ = SFalse + %:== SCJ SCA = SFalse + %:== SCJ SCB = SFalse + %:== SCJ SCC = SFalse + %:== SCJ SCD = SFalse + %:== SCJ SCE = SFalse + %:== SCJ SCF = SFalse + %:== SCJ SCG = SFalse + %:== SCJ SCH = SFalse + %:== SCJ SCI = SFalse + %:== SCJ SCJ = STrue + %:== SCJ SCK = SFalse + %:== SCJ SCL = SFalse + %:== SCJ SCM = SFalse + %:== SCJ SCN = SFalse + %:== SCJ SCO = SFalse + %:== SCJ SCP = SFalse + %:== SCJ SCQ = SFalse + %:== SCJ SCR = SFalse + %:== SCJ SCS = SFalse + %:== SCJ SCT = SFalse + %:== SCJ SCU = SFalse + %:== SCJ SCV = SFalse + %:== SCJ SCW = SFalse + %:== SCJ SCX = SFalse + %:== SCJ SCY = SFalse + %:== SCJ SCZ = SFalse + %:== SCK SCA = SFalse + %:== SCK SCB = SFalse + %:== SCK SCC = SFalse + %:== SCK SCD = SFalse + %:== SCK SCE = SFalse + %:== SCK SCF = SFalse + %:== SCK SCG = SFalse + %:== SCK SCH = SFalse + %:== SCK SCI = SFalse + %:== SCK SCJ = SFalse + %:== SCK SCK = STrue + %:== SCK SCL = SFalse + %:== SCK SCM = SFalse + %:== SCK SCN = SFalse + %:== SCK SCO = SFalse + %:== SCK SCP = SFalse + %:== SCK SCQ = SFalse + %:== SCK SCR = SFalse + %:== SCK SCS = SFalse + %:== SCK SCT = SFalse + %:== SCK SCU = SFalse + %:== SCK SCV = SFalse + %:== SCK SCW = SFalse + %:== SCK SCX = SFalse + %:== SCK SCY = SFalse + %:== SCK SCZ = SFalse + %:== SCL SCA = SFalse + %:== SCL SCB = SFalse + %:== SCL SCC = SFalse + %:== SCL SCD = SFalse + %:== SCL SCE = SFalse + %:== SCL SCF = SFalse + %:== SCL SCG = SFalse + %:== SCL SCH = SFalse + %:== SCL SCI = SFalse + %:== SCL SCJ = SFalse + %:== SCL SCK = SFalse + %:== SCL SCL = STrue + %:== SCL SCM = SFalse + %:== SCL SCN = SFalse + %:== SCL SCO = SFalse + %:== SCL SCP = SFalse + %:== SCL SCQ = SFalse + %:== SCL SCR = SFalse + %:== SCL SCS = SFalse + %:== SCL SCT = SFalse + %:== SCL SCU = SFalse + %:== SCL SCV = SFalse + %:== SCL SCW = SFalse + %:== SCL SCX = SFalse + %:== SCL SCY = SFalse + %:== SCL SCZ = SFalse + %:== SCM SCA = SFalse + %:== SCM SCB = SFalse + %:== SCM SCC = SFalse + %:== SCM SCD = SFalse + %:== SCM SCE = SFalse + %:== SCM SCF = SFalse + %:== SCM SCG = SFalse + %:== SCM SCH = SFalse + %:== SCM SCI = SFalse + %:== SCM SCJ = SFalse + %:== SCM SCK = SFalse + %:== SCM SCL = SFalse + %:== SCM SCM = STrue + %:== SCM SCN = SFalse + %:== SCM SCO = SFalse + %:== SCM SCP = SFalse + %:== SCM SCQ = SFalse + %:== SCM SCR = SFalse + %:== SCM SCS = SFalse + %:== SCM SCT = SFalse + %:== SCM SCU = SFalse + %:== SCM SCV = SFalse + %:== SCM SCW = SFalse + %:== SCM SCX = SFalse + %:== SCM SCY = SFalse + %:== SCM SCZ = SFalse + %:== SCN SCA = SFalse + %:== SCN SCB = SFalse + %:== SCN SCC = SFalse + %:== SCN SCD = SFalse + %:== SCN SCE = SFalse + %:== SCN SCF = SFalse + %:== SCN SCG = SFalse + %:== SCN SCH = SFalse + %:== SCN SCI = SFalse + %:== SCN SCJ = SFalse + %:== SCN SCK = SFalse + %:== SCN SCL = SFalse + %:== SCN SCM = SFalse + %:== SCN SCN = STrue + %:== SCN SCO = SFalse + %:== SCN SCP = SFalse + %:== SCN SCQ = SFalse + %:== SCN SCR = SFalse + %:== SCN SCS = SFalse + %:== SCN SCT = SFalse + %:== SCN SCU = SFalse + %:== SCN SCV = SFalse + %:== SCN SCW = SFalse + %:== SCN SCX = SFalse + %:== SCN SCY = SFalse + %:== SCN SCZ = SFalse + %:== SCO SCA = SFalse + %:== SCO SCB = SFalse + %:== SCO SCC = SFalse + %:== SCO SCD = SFalse + %:== SCO SCE = SFalse + %:== SCO SCF = SFalse + %:== SCO SCG = SFalse + %:== SCO SCH = SFalse + %:== SCO SCI = SFalse + %:== SCO SCJ = SFalse + %:== SCO SCK = SFalse + %:== SCO SCL = SFalse + %:== SCO SCM = SFalse + %:== SCO SCN = SFalse + %:== SCO SCO = STrue + %:== SCO SCP = SFalse + %:== SCO SCQ = SFalse + %:== SCO SCR = SFalse + %:== SCO SCS = SFalse + %:== SCO SCT = SFalse + %:== SCO SCU = SFalse + %:== SCO SCV = SFalse + %:== SCO SCW = SFalse + %:== SCO SCX = SFalse + %:== SCO SCY = SFalse + %:== SCO SCZ = SFalse + %:== SCP SCA = SFalse + %:== SCP SCB = SFalse + %:== SCP SCC = SFalse + %:== SCP SCD = SFalse + %:== SCP SCE = SFalse + %:== SCP SCF = SFalse + %:== SCP SCG = SFalse + %:== SCP SCH = SFalse + %:== SCP SCI = SFalse + %:== SCP SCJ = SFalse + %:== SCP SCK = SFalse + %:== SCP SCL = SFalse + %:== SCP SCM = SFalse + %:== SCP SCN = SFalse + %:== SCP SCO = SFalse + %:== SCP SCP = STrue + %:== SCP SCQ = SFalse + %:== SCP SCR = SFalse + %:== SCP SCS = SFalse + %:== SCP SCT = SFalse + %:== SCP SCU = SFalse + %:== SCP SCV = SFalse + %:== SCP SCW = SFalse + %:== SCP SCX = SFalse + %:== SCP SCY = SFalse + %:== SCP SCZ = SFalse + %:== SCQ SCA = SFalse + %:== SCQ SCB = SFalse + %:== SCQ SCC = SFalse + %:== SCQ SCD = SFalse + %:== SCQ SCE = SFalse + %:== SCQ SCF = SFalse + %:== SCQ SCG = SFalse + %:== SCQ SCH = SFalse + %:== SCQ SCI = SFalse + %:== SCQ SCJ = SFalse + %:== SCQ SCK = SFalse + %:== SCQ SCL = SFalse + %:== SCQ SCM = SFalse + %:== SCQ SCN = SFalse + %:== SCQ SCO = SFalse + %:== SCQ SCP = SFalse + %:== SCQ SCQ = STrue + %:== SCQ SCR = SFalse + %:== SCQ SCS = SFalse + %:== SCQ SCT = SFalse + %:== SCQ SCU = SFalse + %:== SCQ SCV = SFalse + %:== SCQ SCW = SFalse + %:== SCQ SCX = SFalse + %:== SCQ SCY = SFalse + %:== SCQ SCZ = SFalse + %:== SCR SCA = SFalse + %:== SCR SCB = SFalse + %:== SCR SCC = SFalse + %:== SCR SCD = SFalse + %:== SCR SCE = SFalse + %:== SCR SCF = SFalse + %:== SCR SCG = SFalse + %:== SCR SCH = SFalse + %:== SCR SCI = SFalse + %:== SCR SCJ = SFalse + %:== SCR SCK = SFalse + %:== SCR SCL = SFalse + %:== SCR SCM = SFalse + %:== SCR SCN = SFalse + %:== SCR SCO = SFalse + %:== SCR SCP = SFalse + %:== SCR SCQ = SFalse + %:== SCR SCR = STrue + %:== SCR SCS = SFalse + %:== SCR SCT = SFalse + %:== SCR SCU = SFalse + %:== SCR SCV = SFalse + %:== SCR SCW = SFalse + %:== SCR SCX = SFalse + %:== SCR SCY = SFalse + %:== SCR SCZ = SFalse + %:== SCS SCA = SFalse + %:== SCS SCB = SFalse + %:== SCS SCC = SFalse + %:== SCS SCD = SFalse + %:== SCS SCE = SFalse + %:== SCS SCF = SFalse + %:== SCS SCG = SFalse + %:== SCS SCH = SFalse + %:== SCS SCI = SFalse + %:== SCS SCJ = SFalse + %:== SCS SCK = SFalse + %:== SCS SCL = SFalse + %:== SCS SCM = SFalse + %:== SCS SCN = SFalse + %:== SCS SCO = SFalse + %:== SCS SCP = SFalse + %:== SCS SCQ = SFalse + %:== SCS SCR = SFalse + %:== SCS SCS = STrue + %:== SCS SCT = SFalse + %:== SCS SCU = SFalse + %:== SCS SCV = SFalse + %:== SCS SCW = SFalse + %:== SCS SCX = SFalse + %:== SCS SCY = SFalse + %:== SCS SCZ = SFalse + %:== SCT SCA = SFalse + %:== SCT SCB = SFalse + %:== SCT SCC = SFalse + %:== SCT SCD = SFalse + %:== SCT SCE = SFalse + %:== SCT SCF = SFalse + %:== SCT SCG = SFalse + %:== SCT SCH = SFalse + %:== SCT SCI = SFalse + %:== SCT SCJ = SFalse + %:== SCT SCK = SFalse + %:== SCT SCL = SFalse + %:== SCT SCM = SFalse + %:== SCT SCN = SFalse + %:== SCT SCO = SFalse + %:== SCT SCP = SFalse + %:== SCT SCQ = SFalse + %:== SCT SCR = SFalse + %:== SCT SCS = SFalse + %:== SCT SCT = STrue + %:== SCT SCU = SFalse + %:== SCT SCV = SFalse + %:== SCT SCW = SFalse + %:== SCT SCX = SFalse + %:== SCT SCY = SFalse + %:== SCT SCZ = SFalse + %:== SCU SCA = SFalse + %:== SCU SCB = SFalse + %:== SCU SCC = SFalse + %:== SCU SCD = SFalse + %:== SCU SCE = SFalse + %:== SCU SCF = SFalse + %:== SCU SCG = SFalse + %:== SCU SCH = SFalse + %:== SCU SCI = SFalse + %:== SCU SCJ = SFalse + %:== SCU SCK = SFalse + %:== SCU SCL = SFalse + %:== SCU SCM = SFalse + %:== SCU SCN = SFalse + %:== SCU SCO = SFalse + %:== SCU SCP = SFalse + %:== SCU SCQ = SFalse + %:== SCU SCR = SFalse + %:== SCU SCS = SFalse + %:== SCU SCT = SFalse + %:== SCU SCU = STrue + %:== SCU SCV = SFalse + %:== SCU SCW = SFalse + %:== SCU SCX = SFalse + %:== SCU SCY = SFalse + %:== SCU SCZ = SFalse + %:== SCV SCA = SFalse + %:== SCV SCB = SFalse + %:== SCV SCC = SFalse + %:== SCV SCD = SFalse + %:== SCV SCE = SFalse + %:== SCV SCF = SFalse + %:== SCV SCG = SFalse + %:== SCV SCH = SFalse + %:== SCV SCI = SFalse + %:== SCV SCJ = SFalse + %:== SCV SCK = SFalse + %:== SCV SCL = SFalse + %:== SCV SCM = SFalse + %:== SCV SCN = SFalse + %:== SCV SCO = SFalse + %:== SCV SCP = SFalse + %:== SCV SCQ = SFalse + %:== SCV SCR = SFalse + %:== SCV SCS = SFalse + %:== SCV SCT = SFalse + %:== SCV SCU = SFalse + %:== SCV SCV = STrue + %:== SCV SCW = SFalse + %:== SCV SCX = SFalse + %:== SCV SCY = SFalse + %:== SCV SCZ = SFalse + %:== SCW SCA = SFalse + %:== SCW SCB = SFalse + %:== SCW SCC = SFalse + %:== SCW SCD = SFalse + %:== SCW SCE = SFalse + %:== SCW SCF = SFalse + %:== SCW SCG = SFalse + %:== SCW SCH = SFalse + %:== SCW SCI = SFalse + %:== SCW SCJ = SFalse + %:== SCW SCK = SFalse + %:== SCW SCL = SFalse + %:== SCW SCM = SFalse + %:== SCW SCN = SFalse + %:== SCW SCO = SFalse + %:== SCW SCP = SFalse + %:== SCW SCQ = SFalse + %:== SCW SCR = SFalse + %:== SCW SCS = SFalse + %:== SCW SCT = SFalse + %:== SCW SCU = SFalse + %:== SCW SCV = SFalse + %:== SCW SCW = STrue + %:== SCW SCX = SFalse + %:== SCW SCY = SFalse + %:== SCW SCZ = SFalse + %:== SCX SCA = SFalse + %:== SCX SCB = SFalse + %:== SCX SCC = SFalse + %:== SCX SCD = SFalse + %:== SCX SCE = SFalse + %:== SCX SCF = SFalse + %:== SCX SCG = SFalse + %:== SCX SCH = SFalse + %:== SCX SCI = SFalse + %:== SCX SCJ = SFalse + %:== SCX SCK = SFalse + %:== SCX SCL = SFalse + %:== SCX SCM = SFalse + %:== SCX SCN = SFalse + %:== SCX SCO = SFalse + %:== SCX SCP = SFalse + %:== SCX SCQ = SFalse + %:== SCX SCR = SFalse + %:== SCX SCS = SFalse + %:== SCX SCT = SFalse + %:== SCX SCU = SFalse + %:== SCX SCV = SFalse + %:== SCX SCW = SFalse + %:== SCX SCX = STrue + %:== SCX SCY = SFalse + %:== SCX SCZ = SFalse + %:== SCY SCA = SFalse + %:== SCY SCB = SFalse + %:== SCY SCC = SFalse + %:== SCY SCD = SFalse + %:== SCY SCE = SFalse + %:== SCY SCF = SFalse + %:== SCY SCG = SFalse + %:== SCY SCH = SFalse + %:== SCY SCI = SFalse + %:== SCY SCJ = SFalse + %:== SCY SCK = SFalse + %:== SCY SCL = SFalse + %:== SCY SCM = SFalse + %:== SCY SCN = SFalse + %:== SCY SCO = SFalse + %:== SCY SCP = SFalse + %:== SCY SCQ = SFalse + %:== SCY SCR = SFalse + %:== SCY SCS = SFalse + %:== SCY SCT = SFalse + %:== SCY SCU = SFalse + %:== SCY SCV = SFalse + %:== SCY SCW = SFalse + %:== SCY SCX = SFalse + %:== SCY SCY = STrue + %:== SCY SCZ = SFalse + %:== SCZ SCA = SFalse + %:== SCZ SCB = SFalse + %:== SCZ SCC = SFalse + %:== SCZ SCD = SFalse + %:== SCZ SCE = SFalse + %:== SCZ SCF = SFalse + %:== SCZ SCG = SFalse + %:== SCZ SCH = SFalse + %:== SCZ SCI = SFalse + %:== SCZ SCJ = SFalse + %:== SCZ SCK = SFalse + %:== SCZ SCL = SFalse + %:== SCZ SCM = SFalse + %:== SCZ SCN = SFalse + %:== SCZ SCO = SFalse + %:== SCZ SCP = SFalse + %:== SCZ SCQ = SFalse + %:== SCZ SCR = SFalse + %:== SCZ SCS = SFalse + %:== SCZ SCT = SFalse + %:== SCZ SCU = SFalse + %:== SCZ SCV = SFalse + %:== SCZ SCW = SFalse + %:== SCZ SCX = SFalse + %:== SCZ SCY = SFalse + %:== SCZ SCZ = STrue + instance SDecide (KProxy :: KProxy AChar) where + %~ SCA SCA = Proved Refl + %~ SCA SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCA SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCB = Proved Refl + %~ SCB SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCB SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCC = Proved Refl + %~ SCC SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCC SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCD = Proved Refl + %~ SCD SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCD SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCE = Proved Refl + %~ SCE SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCE SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCF = Proved Refl + %~ SCF SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCF SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCG = Proved Refl + %~ SCG SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCG SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCH = Proved Refl + %~ SCH SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCH SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCI = Proved Refl + %~ SCI SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCI SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCJ = Proved Refl + %~ SCJ SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCJ SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCK = Proved Refl + %~ SCK SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCK SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCL = Proved Refl + %~ SCL SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCL SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCM = Proved Refl + %~ SCM SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCM SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCN = Proved Refl + %~ SCN SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCN SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCO = Proved Refl + %~ SCO SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCO SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCP = Proved Refl + %~ SCP SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCP SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCQ = Proved Refl + %~ SCQ SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCQ SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCR = Proved Refl + %~ SCR SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCR SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCS = Proved Refl + %~ SCS SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCS SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCT = Proved Refl + %~ SCT SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCT SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCU = Proved Refl + %~ SCU SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCU SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCV = Proved Refl + %~ SCV SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCV SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCW = Proved Refl + %~ SCW SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCW SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCX = Proved Refl + %~ SCX SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCX SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCY SCY = Proved Refl + %~ SCY SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SCZ SCZ = Proved Refl + instance SingI CA where + sing = SCA + instance SingI CB where + sing = SCB + instance SingI CC where + sing = SCC + instance SingI CD where + sing = SCD + instance SingI CE where + sing = SCE + instance SingI CF where + sing = SCF + instance SingI CG where + sing = SCG + instance SingI CH where + sing = SCH + instance SingI CI where + sing = SCI + instance SingI CJ where + sing = SCJ + instance SingI CK where + sing = SCK + instance SingI CL where + sing = SCL + instance SingI CM where + sing = SCM + instance SingI CN where + sing = SCN + instance SingI CO where + sing = SCO + instance SingI CP where + sing = SCP + instance SingI CQ where + sing = SCQ + instance SingI CR where + sing = SCR + instance SingI CS where + sing = SCS + instance SingI CT where + sing = SCT + instance SingI CU where + sing = SCU + instance SingI CV where + sing = SCV + instance SingI CW where + sing = SCW + instance SingI CX where + sing = SCX + instance SingI CY where + sing = SCY + instance SingI CZ where + sing = SCZ + data instance Sing (z :: Attribute) + = forall (n :: [AChar]) (n :: U). z ~ Attr n n => + SAttr (Sing n) (Sing n) + type SAttribute (z :: Attribute) = Sing z + instance SingKind (KProxy :: KProxy Attribute) where + type instance DemoteRep (KProxy :: KProxy Attribute) = Attribute + fromSing (SAttr b b) = Attr (fromSing b) (fromSing b) + toSing (Attr b b) + = case + (toSing b :: SomeSing (KProxy :: KProxy [AChar]), + toSing b :: SomeSing (KProxy :: KProxy U)) + of { + (SomeSing c, SomeSing c) -> SomeSing (SAttr c c) } + instance (SingI n, SingI n) => + SingI (Attr (n :: [AChar]) (n :: U)) where + sing = SAttr sing sing + data instance Sing (z :: Schema) + = forall (n :: [Attribute]). z ~ Sch n => SSch (Sing n) + type SSchema (z :: Schema) = Sing z + instance SingKind (KProxy :: KProxy Schema) where + type instance DemoteRep (KProxy :: KProxy Schema) = Schema + fromSing (SSch b) = Sch (fromSing b) + toSing (Sch b) + = case toSing b :: SomeSing (KProxy :: KProxy [Attribute]) of { + SomeSing c -> SomeSing (SSch c) } + instance SingI n => SingI (Sch (n :: [Attribute])) where + sing = SSch sing + sAppend :: + forall (t :: Schema) (t :: Schema). + Sing t -> Sing t -> Sing (Append t t) + sAppend (SSch s1) (SSch s2) = SSch ((%:++) s1 s2) + sAttrNotIn :: + forall (t :: Attribute) (t :: Schema). + Sing t -> Sing t -> Sing (AttrNotIn t t) + sAttrNotIn _ (SSch SNil) = STrue + sAttrNotIn (SAttr name u) (SSch (SCons (SAttr name' _) t)) + = (%:&&) ((%:/=) name name') (sAttrNotIn (SAttr name u) (SSch t)) + sDisjoint :: + forall (t :: Schema) (t :: Schema). + Sing t -> Sing t -> Sing (Disjoint t t) + sDisjoint (SSch SNil) _ = STrue + sDisjoint (SSch (SCons h t)) s + = (%:&&) (sAttrNotIn h s) (sDisjoint (SSch t) s) + sOccurs :: + forall (t :: [AChar]) (t :: Schema). + Sing t -> Sing t -> Sing (Occurs t t) + sOccurs _ (SSch SNil) = SFalse + sOccurs name (SSch (SCons (SAttr name' _) attrs)) + = (%:||) ((%:==) name name') (sOccurs name (SSch attrs)) + sLookup :: + forall (t :: [AChar]) (t :: Schema). + Sing t -> Sing t -> Sing (Lookup t t) + sLookup _ (SSch SNil) = undefined + sLookup name (SSch (SCons (SAttr name' u) attrs)) + = sIf ((%:==) name name') u (sLookup name (SSch attrs)) +GradingClient/Database.hs:0:0: Splicing declarations + return [] ======> GradingClient/Database.hs:0:0: +GradingClient/Database.hs:(0,0)-(0,0): Splicing expression + cases ''Row [| r |] [| changeId (n ++ (getId r)) r |] + ======> + case r of { + EmptyRow _ -> changeId (n ++ (getId r)) r + ConsRow _ _ -> changeId (n ++ (getId r)) r } diff --git a/tests/compile-and-dump/GradingClient/Database.ghc78.template b/tests/compile-and-dump/GradingClient/Database.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/GradingClient/Database.ghc78.template @@ -0,0 +1,3812 @@ +GradingClient/Database.hs:0:0: Splicing declarations + singletons + [d| data Nat + = Zero | Succ Nat + deriving (Eq, Ord) |] + ======> + GradingClient/Database.hs:(0,0)-(0,0) + data Nat + = Zero | Succ Nat + deriving (Eq, Ord) + type family Equals_0123456789 (a :: Nat) (b :: Nat) :: Bool where + Equals_0123456789 Zero Zero = True + Equals_0123456789 (Succ a) (Succ b) = (==) a b + Equals_0123456789 (a :: Nat) (b :: Nat) = False + type instance (==) (a :: Nat) (b :: Nat) = Equals_0123456789 a b + data instance Sing (z :: Nat) + = z ~ Zero => SZero | + forall (n :: Nat). z ~ Succ n => SSucc (Sing n) + type SNat (z :: Nat) = Sing z + instance SingKind (KProxy :: KProxy Nat) where + type DemoteRep (KProxy :: KProxy Nat) = Nat + fromSing SZero = Zero + fromSing (SSucc b) = Succ (fromSing b) + toSing Zero = SomeSing SZero + toSing (Succ b) + = case toSing b :: SomeSing (KProxy :: KProxy Nat) of { + SomeSing c -> SomeSing (SSucc c) } + instance SEq (KProxy :: KProxy Nat) where + (%:==) SZero SZero = STrue + (%:==) SZero (SSucc _) = SFalse + (%:==) (SSucc _) SZero = SFalse + (%:==) (SSucc a) (SSucc b) = (%:==) a b + instance SDecide (KProxy :: KProxy Nat) where + (%~) SZero SZero = Proved Refl + (%~) SZero (SSucc _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SSucc _) SZero + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SSucc a) (SSucc b) + = case (%~) a b of { + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\ Refl -> contra Refl) } + instance SingI Zero where + sing = SZero + instance SingI n => SingI (Succ (n :: Nat)) where + sing = SSucc sing +GradingClient/Database.hs:0:0: Splicing declarations + singletons + [d| append :: Schema -> Schema -> Schema + append (Sch s1) (Sch s2) = Sch (s1 ++ s2) + attrNotIn :: Attribute -> Schema -> Bool + attrNotIn _ (Sch []) = True + attrNotIn (Attr name u) (Sch ((Attr name' _) : t)) + = (name /= name') && (attrNotIn (Attr name u) (Sch t)) + disjoint :: Schema -> Schema -> Bool + disjoint (Sch []) _ = True + disjoint (Sch (h : t)) s = (attrNotIn h s) && (disjoint (Sch t) s) + occurs :: [AChar] -> Schema -> Bool + occurs _ (Sch []) = False + occurs name (Sch ((Attr name' _) : attrs)) + = name == name' || occurs name (Sch attrs) + lookup :: [AChar] -> Schema -> U + lookup _ (Sch []) = undefined + lookup name (Sch ((Attr name' u) : attrs)) + = if name == name' then u else lookup name (Sch attrs) + + data U + = BOOL | STRING | NAT | VEC U Nat + deriving (Read, Eq, Show) + data AChar + = CA | + CB | + CC | + CD | + CE | + CF | + CG | + CH | + CI | + CJ | + CK | + CL | + CM | + CN | + CO | + CP | + CQ | + CR | + CS | + CT | + CU | + CV | + CW | + CX | + CY | + CZ + deriving (Read, Show, Eq) + data Attribute = Attr [AChar] U + data Schema = Sch [Attribute] |] + ======> + GradingClient/Database.hs:(0,0)-(0,0) + data U + = BOOL | STRING | NAT | VEC U Nat + deriving (Read, Eq, Show) + data AChar + = CA | + CB | + CC | + CD | + CE | + CF | + CG | + CH | + CI | + CJ | + CK | + CL | + CM | + CN | + CO | + CP | + CQ | + CR | + CS | + CT | + CU | + CV | + CW | + CX | + CY | + CZ + deriving (Read, Show, Eq) + data Attribute = Attr [AChar] U + data Schema = Sch [Attribute] + append :: Schema -> Schema -> Schema + append (Sch s1) (Sch s2) = Sch (s1 ++ s2) + attrNotIn :: Attribute -> Schema -> Bool + attrNotIn _ (Sch GHC.Types.[]) = True + attrNotIn (Attr name u) (Sch ((Attr name' _) GHC.Types.: t)) + = ((name /= name') && (attrNotIn (Attr name u) (Sch t))) + disjoint :: Schema -> Schema -> Bool + disjoint (Sch GHC.Types.[]) _ = True + disjoint (Sch (h GHC.Types.: t)) s + = ((attrNotIn h s) && (disjoint (Sch t) s)) + occurs :: [AChar] -> Schema -> Bool + occurs _ (Sch GHC.Types.[]) = False + occurs name (Sch ((Attr name' _) GHC.Types.: attrs)) + = ((name == name') || (occurs name (Sch attrs))) + lookup :: [AChar] -> Schema -> U + lookup _ (Sch GHC.Types.[]) = undefined + lookup name (Sch ((Attr name' u) GHC.Types.: attrs)) + = if (name == name') then u else lookup name (Sch attrs) + type family Equals_0123456789 (a :: U) (b :: U) :: Bool where + Equals_0123456789 BOOL BOOL = True + Equals_0123456789 STRING STRING = True + Equals_0123456789 NAT NAT = True + Equals_0123456789 (VEC a a) (VEC b b) = (:&&) ((==) a b) ((==) a b) + Equals_0123456789 (a :: U) (b :: U) = False + type instance (==) (a :: U) (b :: U) = Equals_0123456789 a b + type family Equals_0123456789 (a :: AChar) + (b :: AChar) :: Bool where + Equals_0123456789 CA CA = True + Equals_0123456789 CB CB = True + Equals_0123456789 CC CC = True + Equals_0123456789 CD CD = True + Equals_0123456789 CE CE = True + Equals_0123456789 CF CF = True + Equals_0123456789 CG CG = True + Equals_0123456789 CH CH = True + Equals_0123456789 CI CI = True + Equals_0123456789 CJ CJ = True + Equals_0123456789 CK CK = True + Equals_0123456789 CL CL = True + Equals_0123456789 CM CM = True + Equals_0123456789 CN CN = True + Equals_0123456789 CO CO = True + Equals_0123456789 CP CP = True + Equals_0123456789 CQ CQ = True + Equals_0123456789 CR CR = True + Equals_0123456789 CS CS = True + Equals_0123456789 CT CT = True + Equals_0123456789 CU CU = True + Equals_0123456789 CV CV = True + Equals_0123456789 CW CW = True + Equals_0123456789 CX CX = True + Equals_0123456789 CY CY = True + Equals_0123456789 CZ CZ = True + Equals_0123456789 (a :: AChar) (b :: AChar) = False + type instance (==) (a :: AChar) (b :: AChar) = Equals_0123456789 a b + type family Append (a :: Schema) (a :: Schema) :: Schema where + Append (Sch s1) (Sch s2) = Sch ((:++) s1 s2) + type family AttrNotIn (a :: Attribute) (a :: Schema) :: Bool where + AttrNotIn z (Sch GHC.Types.[]) = True + AttrNotIn (Attr name u) (Sch ((GHC.Types.:) (Attr name' z) t)) = (:&&) ((:/=) name name') (AttrNotIn (Attr name u) (Sch t)) + type family Disjoint (a :: Schema) (a :: Schema) :: Bool where + Disjoint (Sch GHC.Types.[]) z = True + Disjoint (Sch ((GHC.Types.:) h t)) s = (:&&) (AttrNotIn h s) (Disjoint (Sch t) s) + type family Occurs (a :: [AChar]) (a :: Schema) :: Bool where + Occurs z (Sch GHC.Types.[]) = False + Occurs name (Sch ((GHC.Types.:) (Attr name' z) attrs)) = (:||) ((:==) name name') (Occurs name (Sch attrs)) + type family Lookup (a :: [AChar]) (a :: Schema) :: U where + Lookup z (Sch GHC.Types.[]) = Any + Lookup name (Sch ((GHC.Types.:) (Attr name' u) attrs)) = If ((:==) name name') u (Lookup name (Sch attrs)) + data instance Sing (z :: U) + = z ~ BOOL => SBOOL | + z ~ STRING => SSTRING | + z ~ NAT => SNAT | + forall (n :: U) (n :: Nat). z ~ VEC n n => SVEC (Sing n) (Sing n) + type SU (z :: U) = Sing z + instance SingKind (KProxy :: KProxy U) where + type DemoteRep (KProxy :: KProxy U) = U + fromSing SBOOL = BOOL + fromSing SSTRING = STRING + fromSing SNAT = NAT + fromSing (SVEC b b) = VEC (fromSing b) (fromSing b) + toSing BOOL = SomeSing SBOOL + toSing STRING = SomeSing SSTRING + toSing NAT = SomeSing SNAT + toSing (VEC b b) + = case + (toSing b :: SomeSing (KProxy :: KProxy U), + toSing b :: SomeSing (KProxy :: KProxy Nat)) + of { + (SomeSing c, SomeSing c) -> SomeSing (SVEC c c) } + instance SEq (KProxy :: KProxy U) where + (%:==) SBOOL SBOOL = STrue + (%:==) SBOOL SSTRING = SFalse + (%:==) SBOOL SNAT = SFalse + (%:==) SBOOL (SVEC _ _) = SFalse + (%:==) SSTRING SBOOL = SFalse + (%:==) SSTRING SSTRING = STrue + (%:==) SSTRING SNAT = SFalse + (%:==) SSTRING (SVEC _ _) = SFalse + (%:==) SNAT SBOOL = SFalse + (%:==) SNAT SSTRING = SFalse + (%:==) SNAT SNAT = STrue + (%:==) SNAT (SVEC _ _) = SFalse + (%:==) (SVEC _ _) SBOOL = SFalse + (%:==) (SVEC _ _) SSTRING = SFalse + (%:==) (SVEC _ _) SNAT = SFalse + (%:==) (SVEC a a) (SVEC b b) = (%:&&) ((%:==) a b) ((%:==) a b) + instance SDecide (KProxy :: KProxy U) where + (%~) SBOOL SBOOL = Proved Refl + (%~) SBOOL SSTRING + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SBOOL SNAT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SBOOL (SVEC _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SSTRING SBOOL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SSTRING SSTRING = Proved Refl + (%~) SSTRING SNAT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SSTRING (SVEC _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SNAT SBOOL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SNAT SSTRING + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SNAT SNAT = Proved Refl + (%~) SNAT (SVEC _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SVEC _ _) SBOOL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SVEC _ _) SSTRING + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SVEC _ _) SNAT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SVEC a a) (SVEC b b) + = case ((%~) a b, (%~) a b) of { + (Proved Refl, Proved Refl) -> Proved Refl + (Disproved contra, _) -> Disproved (\ Refl -> contra Refl) + (_, Disproved contra) -> Disproved (\ Refl -> contra Refl) } + instance SingI BOOL where + sing = SBOOL + instance SingI STRING where + sing = SSTRING + instance SingI NAT where + sing = SNAT + instance (SingI n, SingI n) => + SingI (VEC (n :: U) (n :: Nat)) where + sing = SVEC sing sing + data instance Sing (z :: AChar) + = z ~ CA => SCA | + z ~ CB => SCB | + z ~ CC => SCC | + z ~ CD => SCD | + z ~ CE => SCE | + z ~ CF => SCF | + z ~ CG => SCG | + z ~ CH => SCH | + z ~ CI => SCI | + z ~ CJ => SCJ | + z ~ CK => SCK | + z ~ CL => SCL | + z ~ CM => SCM | + z ~ CN => SCN | + z ~ CO => SCO | + z ~ CP => SCP | + z ~ CQ => SCQ | + z ~ CR => SCR | + z ~ CS => SCS | + z ~ CT => SCT | + z ~ CU => SCU | + z ~ CV => SCV | + z ~ CW => SCW | + z ~ CX => SCX | + z ~ CY => SCY | + z ~ CZ => SCZ + type SAChar (z :: AChar) = Sing z + instance SingKind (KProxy :: KProxy AChar) where + type DemoteRep (KProxy :: KProxy AChar) = AChar + fromSing SCA = CA + fromSing SCB = CB + fromSing SCC = CC + fromSing SCD = CD + fromSing SCE = CE + fromSing SCF = CF + fromSing SCG = CG + fromSing SCH = CH + fromSing SCI = CI + fromSing SCJ = CJ + fromSing SCK = CK + fromSing SCL = CL + fromSing SCM = CM + fromSing SCN = CN + fromSing SCO = CO + fromSing SCP = CP + fromSing SCQ = CQ + fromSing SCR = CR + fromSing SCS = CS + fromSing SCT = CT + fromSing SCU = CU + fromSing SCV = CV + fromSing SCW = CW + fromSing SCX = CX + fromSing SCY = CY + fromSing SCZ = CZ + toSing CA = SomeSing SCA + toSing CB = SomeSing SCB + toSing CC = SomeSing SCC + toSing CD = SomeSing SCD + toSing CE = SomeSing SCE + toSing CF = SomeSing SCF + toSing CG = SomeSing SCG + toSing CH = SomeSing SCH + toSing CI = SomeSing SCI + toSing CJ = SomeSing SCJ + toSing CK = SomeSing SCK + toSing CL = SomeSing SCL + toSing CM = SomeSing SCM + toSing CN = SomeSing SCN + toSing CO = SomeSing SCO + toSing CP = SomeSing SCP + toSing CQ = SomeSing SCQ + toSing CR = SomeSing SCR + toSing CS = SomeSing SCS + toSing CT = SomeSing SCT + toSing CU = SomeSing SCU + toSing CV = SomeSing SCV + toSing CW = SomeSing SCW + toSing CX = SomeSing SCX + toSing CY = SomeSing SCY + toSing CZ = SomeSing SCZ + instance SEq (KProxy :: KProxy AChar) where + (%:==) SCA SCA = STrue + (%:==) SCA SCB = SFalse + (%:==) SCA SCC = SFalse + (%:==) SCA SCD = SFalse + (%:==) SCA SCE = SFalse + (%:==) SCA SCF = SFalse + (%:==) SCA SCG = SFalse + (%:==) SCA SCH = SFalse + (%:==) SCA SCI = SFalse + (%:==) SCA SCJ = SFalse + (%:==) SCA SCK = SFalse + (%:==) SCA SCL = SFalse + (%:==) SCA SCM = SFalse + (%:==) SCA SCN = SFalse + (%:==) SCA SCO = SFalse + (%:==) SCA SCP = SFalse + (%:==) SCA SCQ = SFalse + (%:==) SCA SCR = SFalse + (%:==) SCA SCS = SFalse + (%:==) SCA SCT = SFalse + (%:==) SCA SCU = SFalse + (%:==) SCA SCV = SFalse + (%:==) SCA SCW = SFalse + (%:==) SCA SCX = SFalse + (%:==) SCA SCY = SFalse + (%:==) SCA SCZ = SFalse + (%:==) SCB SCA = SFalse + (%:==) SCB SCB = STrue + (%:==) SCB SCC = SFalse + (%:==) SCB SCD = SFalse + (%:==) SCB SCE = SFalse + (%:==) SCB SCF = SFalse + (%:==) SCB SCG = SFalse + (%:==) SCB SCH = SFalse + (%:==) SCB SCI = SFalse + (%:==) SCB SCJ = SFalse + (%:==) SCB SCK = SFalse + (%:==) SCB SCL = SFalse + (%:==) SCB SCM = SFalse + (%:==) SCB SCN = SFalse + (%:==) SCB SCO = SFalse + (%:==) SCB SCP = SFalse + (%:==) SCB SCQ = SFalse + (%:==) SCB SCR = SFalse + (%:==) SCB SCS = SFalse + (%:==) SCB SCT = SFalse + (%:==) SCB SCU = SFalse + (%:==) SCB SCV = SFalse + (%:==) SCB SCW = SFalse + (%:==) SCB SCX = SFalse + (%:==) SCB SCY = SFalse + (%:==) SCB SCZ = SFalse + (%:==) SCC SCA = SFalse + (%:==) SCC SCB = SFalse + (%:==) SCC SCC = STrue + (%:==) SCC SCD = SFalse + (%:==) SCC SCE = SFalse + (%:==) SCC SCF = SFalse + (%:==) SCC SCG = SFalse + (%:==) SCC SCH = SFalse + (%:==) SCC SCI = SFalse + (%:==) SCC SCJ = SFalse + (%:==) SCC SCK = SFalse + (%:==) SCC SCL = SFalse + (%:==) SCC SCM = SFalse + (%:==) SCC SCN = SFalse + (%:==) SCC SCO = SFalse + (%:==) SCC SCP = SFalse + (%:==) SCC SCQ = SFalse + (%:==) SCC SCR = SFalse + (%:==) SCC SCS = SFalse + (%:==) SCC SCT = SFalse + (%:==) SCC SCU = SFalse + (%:==) SCC SCV = SFalse + (%:==) SCC SCW = SFalse + (%:==) SCC SCX = SFalse + (%:==) SCC SCY = SFalse + (%:==) SCC SCZ = SFalse + (%:==) SCD SCA = SFalse + (%:==) SCD SCB = SFalse + (%:==) SCD SCC = SFalse + (%:==) SCD SCD = STrue + (%:==) SCD SCE = SFalse + (%:==) SCD SCF = SFalse + (%:==) SCD SCG = SFalse + (%:==) SCD SCH = SFalse + (%:==) SCD SCI = SFalse + (%:==) SCD SCJ = SFalse + (%:==) SCD SCK = SFalse + (%:==) SCD SCL = SFalse + (%:==) SCD SCM = SFalse + (%:==) SCD SCN = SFalse + (%:==) SCD SCO = SFalse + (%:==) SCD SCP = SFalse + (%:==) SCD SCQ = SFalse + (%:==) SCD SCR = SFalse + (%:==) SCD SCS = SFalse + (%:==) SCD SCT = SFalse + (%:==) SCD SCU = SFalse + (%:==) SCD SCV = SFalse + (%:==) SCD SCW = SFalse + (%:==) SCD SCX = SFalse + (%:==) SCD SCY = SFalse + (%:==) SCD SCZ = SFalse + (%:==) SCE SCA = SFalse + (%:==) SCE SCB = SFalse + (%:==) SCE SCC = SFalse + (%:==) SCE SCD = SFalse + (%:==) SCE SCE = STrue + (%:==) SCE SCF = SFalse + (%:==) SCE SCG = SFalse + (%:==) SCE SCH = SFalse + (%:==) SCE SCI = SFalse + (%:==) SCE SCJ = SFalse + (%:==) SCE SCK = SFalse + (%:==) SCE SCL = SFalse + (%:==) SCE SCM = SFalse + (%:==) SCE SCN = SFalse + (%:==) SCE SCO = SFalse + (%:==) SCE SCP = SFalse + (%:==) SCE SCQ = SFalse + (%:==) SCE SCR = SFalse + (%:==) SCE SCS = SFalse + (%:==) SCE SCT = SFalse + (%:==) SCE SCU = SFalse + (%:==) SCE SCV = SFalse + (%:==) SCE SCW = SFalse + (%:==) SCE SCX = SFalse + (%:==) SCE SCY = SFalse + (%:==) SCE SCZ = SFalse + (%:==) SCF SCA = SFalse + (%:==) SCF SCB = SFalse + (%:==) SCF SCC = SFalse + (%:==) SCF SCD = SFalse + (%:==) SCF SCE = SFalse + (%:==) SCF SCF = STrue + (%:==) SCF SCG = SFalse + (%:==) SCF SCH = SFalse + (%:==) SCF SCI = SFalse + (%:==) SCF SCJ = SFalse + (%:==) SCF SCK = SFalse + (%:==) SCF SCL = SFalse + (%:==) SCF SCM = SFalse + (%:==) SCF SCN = SFalse + (%:==) SCF SCO = SFalse + (%:==) SCF SCP = SFalse + (%:==) SCF SCQ = SFalse + (%:==) SCF SCR = SFalse + (%:==) SCF SCS = SFalse + (%:==) SCF SCT = SFalse + (%:==) SCF SCU = SFalse + (%:==) SCF SCV = SFalse + (%:==) SCF SCW = SFalse + (%:==) SCF SCX = SFalse + (%:==) SCF SCY = SFalse + (%:==) SCF SCZ = SFalse + (%:==) SCG SCA = SFalse + (%:==) SCG SCB = SFalse + (%:==) SCG SCC = SFalse + (%:==) SCG SCD = SFalse + (%:==) SCG SCE = SFalse + (%:==) SCG SCF = SFalse + (%:==) SCG SCG = STrue + (%:==) SCG SCH = SFalse + (%:==) SCG SCI = SFalse + (%:==) SCG SCJ = SFalse + (%:==) SCG SCK = SFalse + (%:==) SCG SCL = SFalse + (%:==) SCG SCM = SFalse + (%:==) SCG SCN = SFalse + (%:==) SCG SCO = SFalse + (%:==) SCG SCP = SFalse + (%:==) SCG SCQ = SFalse + (%:==) SCG SCR = SFalse + (%:==) SCG SCS = SFalse + (%:==) SCG SCT = SFalse + (%:==) SCG SCU = SFalse + (%:==) SCG SCV = SFalse + (%:==) SCG SCW = SFalse + (%:==) SCG SCX = SFalse + (%:==) SCG SCY = SFalse + (%:==) SCG SCZ = SFalse + (%:==) SCH SCA = SFalse + (%:==) SCH SCB = SFalse + (%:==) SCH SCC = SFalse + (%:==) SCH SCD = SFalse + (%:==) SCH SCE = SFalse + (%:==) SCH SCF = SFalse + (%:==) SCH SCG = SFalse + (%:==) SCH SCH = STrue + (%:==) SCH SCI = SFalse + (%:==) SCH SCJ = SFalse + (%:==) SCH SCK = SFalse + (%:==) SCH SCL = SFalse + (%:==) SCH SCM = SFalse + (%:==) SCH SCN = SFalse + (%:==) SCH SCO = SFalse + (%:==) SCH SCP = SFalse + (%:==) SCH SCQ = SFalse + (%:==) SCH SCR = SFalse + (%:==) SCH SCS = SFalse + (%:==) SCH SCT = SFalse + (%:==) SCH SCU = SFalse + (%:==) SCH SCV = SFalse + (%:==) SCH SCW = SFalse + (%:==) SCH SCX = SFalse + (%:==) SCH SCY = SFalse + (%:==) SCH SCZ = SFalse + (%:==) SCI SCA = SFalse + (%:==) SCI SCB = SFalse + (%:==) SCI SCC = SFalse + (%:==) SCI SCD = SFalse + (%:==) SCI SCE = SFalse + (%:==) SCI SCF = SFalse + (%:==) SCI SCG = SFalse + (%:==) SCI SCH = SFalse + (%:==) SCI SCI = STrue + (%:==) SCI SCJ = SFalse + (%:==) SCI SCK = SFalse + (%:==) SCI SCL = SFalse + (%:==) SCI SCM = SFalse + (%:==) SCI SCN = SFalse + (%:==) SCI SCO = SFalse + (%:==) SCI SCP = SFalse + (%:==) SCI SCQ = SFalse + (%:==) SCI SCR = SFalse + (%:==) SCI SCS = SFalse + (%:==) SCI SCT = SFalse + (%:==) SCI SCU = SFalse + (%:==) SCI SCV = SFalse + (%:==) SCI SCW = SFalse + (%:==) SCI SCX = SFalse + (%:==) SCI SCY = SFalse + (%:==) SCI SCZ = SFalse + (%:==) SCJ SCA = SFalse + (%:==) SCJ SCB = SFalse + (%:==) SCJ SCC = SFalse + (%:==) SCJ SCD = SFalse + (%:==) SCJ SCE = SFalse + (%:==) SCJ SCF = SFalse + (%:==) SCJ SCG = SFalse + (%:==) SCJ SCH = SFalse + (%:==) SCJ SCI = SFalse + (%:==) SCJ SCJ = STrue + (%:==) SCJ SCK = SFalse + (%:==) SCJ SCL = SFalse + (%:==) SCJ SCM = SFalse + (%:==) SCJ SCN = SFalse + (%:==) SCJ SCO = SFalse + (%:==) SCJ SCP = SFalse + (%:==) SCJ SCQ = SFalse + (%:==) SCJ SCR = SFalse + (%:==) SCJ SCS = SFalse + (%:==) SCJ SCT = SFalse + (%:==) SCJ SCU = SFalse + (%:==) SCJ SCV = SFalse + (%:==) SCJ SCW = SFalse + (%:==) SCJ SCX = SFalse + (%:==) SCJ SCY = SFalse + (%:==) SCJ SCZ = SFalse + (%:==) SCK SCA = SFalse + (%:==) SCK SCB = SFalse + (%:==) SCK SCC = SFalse + (%:==) SCK SCD = SFalse + (%:==) SCK SCE = SFalse + (%:==) SCK SCF = SFalse + (%:==) SCK SCG = SFalse + (%:==) SCK SCH = SFalse + (%:==) SCK SCI = SFalse + (%:==) SCK SCJ = SFalse + (%:==) SCK SCK = STrue + (%:==) SCK SCL = SFalse + (%:==) SCK SCM = SFalse + (%:==) SCK SCN = SFalse + (%:==) SCK SCO = SFalse + (%:==) SCK SCP = SFalse + (%:==) SCK SCQ = SFalse + (%:==) SCK SCR = SFalse + (%:==) SCK SCS = SFalse + (%:==) SCK SCT = SFalse + (%:==) SCK SCU = SFalse + (%:==) SCK SCV = SFalse + (%:==) SCK SCW = SFalse + (%:==) SCK SCX = SFalse + (%:==) SCK SCY = SFalse + (%:==) SCK SCZ = SFalse + (%:==) SCL SCA = SFalse + (%:==) SCL SCB = SFalse + (%:==) SCL SCC = SFalse + (%:==) SCL SCD = SFalse + (%:==) SCL SCE = SFalse + (%:==) SCL SCF = SFalse + (%:==) SCL SCG = SFalse + (%:==) SCL SCH = SFalse + (%:==) SCL SCI = SFalse + (%:==) SCL SCJ = SFalse + (%:==) SCL SCK = SFalse + (%:==) SCL SCL = STrue + (%:==) SCL SCM = SFalse + (%:==) SCL SCN = SFalse + (%:==) SCL SCO = SFalse + (%:==) SCL SCP = SFalse + (%:==) SCL SCQ = SFalse + (%:==) SCL SCR = SFalse + (%:==) SCL SCS = SFalse + (%:==) SCL SCT = SFalse + (%:==) SCL SCU = SFalse + (%:==) SCL SCV = SFalse + (%:==) SCL SCW = SFalse + (%:==) SCL SCX = SFalse + (%:==) SCL SCY = SFalse + (%:==) SCL SCZ = SFalse + (%:==) SCM SCA = SFalse + (%:==) SCM SCB = SFalse + (%:==) SCM SCC = SFalse + (%:==) SCM SCD = SFalse + (%:==) SCM SCE = SFalse + (%:==) SCM SCF = SFalse + (%:==) SCM SCG = SFalse + (%:==) SCM SCH = SFalse + (%:==) SCM SCI = SFalse + (%:==) SCM SCJ = SFalse + (%:==) SCM SCK = SFalse + (%:==) SCM SCL = SFalse + (%:==) SCM SCM = STrue + (%:==) SCM SCN = SFalse + (%:==) SCM SCO = SFalse + (%:==) SCM SCP = SFalse + (%:==) SCM SCQ = SFalse + (%:==) SCM SCR = SFalse + (%:==) SCM SCS = SFalse + (%:==) SCM SCT = SFalse + (%:==) SCM SCU = SFalse + (%:==) SCM SCV = SFalse + (%:==) SCM SCW = SFalse + (%:==) SCM SCX = SFalse + (%:==) SCM SCY = SFalse + (%:==) SCM SCZ = SFalse + (%:==) SCN SCA = SFalse + (%:==) SCN SCB = SFalse + (%:==) SCN SCC = SFalse + (%:==) SCN SCD = SFalse + (%:==) SCN SCE = SFalse + (%:==) SCN SCF = SFalse + (%:==) SCN SCG = SFalse + (%:==) SCN SCH = SFalse + (%:==) SCN SCI = SFalse + (%:==) SCN SCJ = SFalse + (%:==) SCN SCK = SFalse + (%:==) SCN SCL = SFalse + (%:==) SCN SCM = SFalse + (%:==) SCN SCN = STrue + (%:==) SCN SCO = SFalse + (%:==) SCN SCP = SFalse + (%:==) SCN SCQ = SFalse + (%:==) SCN SCR = SFalse + (%:==) SCN SCS = SFalse + (%:==) SCN SCT = SFalse + (%:==) SCN SCU = SFalse + (%:==) SCN SCV = SFalse + (%:==) SCN SCW = SFalse + (%:==) SCN SCX = SFalse + (%:==) SCN SCY = SFalse + (%:==) SCN SCZ = SFalse + (%:==) SCO SCA = SFalse + (%:==) SCO SCB = SFalse + (%:==) SCO SCC = SFalse + (%:==) SCO SCD = SFalse + (%:==) SCO SCE = SFalse + (%:==) SCO SCF = SFalse + (%:==) SCO SCG = SFalse + (%:==) SCO SCH = SFalse + (%:==) SCO SCI = SFalse + (%:==) SCO SCJ = SFalse + (%:==) SCO SCK = SFalse + (%:==) SCO SCL = SFalse + (%:==) SCO SCM = SFalse + (%:==) SCO SCN = SFalse + (%:==) SCO SCO = STrue + (%:==) SCO SCP = SFalse + (%:==) SCO SCQ = SFalse + (%:==) SCO SCR = SFalse + (%:==) SCO SCS = SFalse + (%:==) SCO SCT = SFalse + (%:==) SCO SCU = SFalse + (%:==) SCO SCV = SFalse + (%:==) SCO SCW = SFalse + (%:==) SCO SCX = SFalse + (%:==) SCO SCY = SFalse + (%:==) SCO SCZ = SFalse + (%:==) SCP SCA = SFalse + (%:==) SCP SCB = SFalse + (%:==) SCP SCC = SFalse + (%:==) SCP SCD = SFalse + (%:==) SCP SCE = SFalse + (%:==) SCP SCF = SFalse + (%:==) SCP SCG = SFalse + (%:==) SCP SCH = SFalse + (%:==) SCP SCI = SFalse + (%:==) SCP SCJ = SFalse + (%:==) SCP SCK = SFalse + (%:==) SCP SCL = SFalse + (%:==) SCP SCM = SFalse + (%:==) SCP SCN = SFalse + (%:==) SCP SCO = SFalse + (%:==) SCP SCP = STrue + (%:==) SCP SCQ = SFalse + (%:==) SCP SCR = SFalse + (%:==) SCP SCS = SFalse + (%:==) SCP SCT = SFalse + (%:==) SCP SCU = SFalse + (%:==) SCP SCV = SFalse + (%:==) SCP SCW = SFalse + (%:==) SCP SCX = SFalse + (%:==) SCP SCY = SFalse + (%:==) SCP SCZ = SFalse + (%:==) SCQ SCA = SFalse + (%:==) SCQ SCB = SFalse + (%:==) SCQ SCC = SFalse + (%:==) SCQ SCD = SFalse + (%:==) SCQ SCE = SFalse + (%:==) SCQ SCF = SFalse + (%:==) SCQ SCG = SFalse + (%:==) SCQ SCH = SFalse + (%:==) SCQ SCI = SFalse + (%:==) SCQ SCJ = SFalse + (%:==) SCQ SCK = SFalse + (%:==) SCQ SCL = SFalse + (%:==) SCQ SCM = SFalse + (%:==) SCQ SCN = SFalse + (%:==) SCQ SCO = SFalse + (%:==) SCQ SCP = SFalse + (%:==) SCQ SCQ = STrue + (%:==) SCQ SCR = SFalse + (%:==) SCQ SCS = SFalse + (%:==) SCQ SCT = SFalse + (%:==) SCQ SCU = SFalse + (%:==) SCQ SCV = SFalse + (%:==) SCQ SCW = SFalse + (%:==) SCQ SCX = SFalse + (%:==) SCQ SCY = SFalse + (%:==) SCQ SCZ = SFalse + (%:==) SCR SCA = SFalse + (%:==) SCR SCB = SFalse + (%:==) SCR SCC = SFalse + (%:==) SCR SCD = SFalse + (%:==) SCR SCE = SFalse + (%:==) SCR SCF = SFalse + (%:==) SCR SCG = SFalse + (%:==) SCR SCH = SFalse + (%:==) SCR SCI = SFalse + (%:==) SCR SCJ = SFalse + (%:==) SCR SCK = SFalse + (%:==) SCR SCL = SFalse + (%:==) SCR SCM = SFalse + (%:==) SCR SCN = SFalse + (%:==) SCR SCO = SFalse + (%:==) SCR SCP = SFalse + (%:==) SCR SCQ = SFalse + (%:==) SCR SCR = STrue + (%:==) SCR SCS = SFalse + (%:==) SCR SCT = SFalse + (%:==) SCR SCU = SFalse + (%:==) SCR SCV = SFalse + (%:==) SCR SCW = SFalse + (%:==) SCR SCX = SFalse + (%:==) SCR SCY = SFalse + (%:==) SCR SCZ = SFalse + (%:==) SCS SCA = SFalse + (%:==) SCS SCB = SFalse + (%:==) SCS SCC = SFalse + (%:==) SCS SCD = SFalse + (%:==) SCS SCE = SFalse + (%:==) SCS SCF = SFalse + (%:==) SCS SCG = SFalse + (%:==) SCS SCH = SFalse + (%:==) SCS SCI = SFalse + (%:==) SCS SCJ = SFalse + (%:==) SCS SCK = SFalse + (%:==) SCS SCL = SFalse + (%:==) SCS SCM = SFalse + (%:==) SCS SCN = SFalse + (%:==) SCS SCO = SFalse + (%:==) SCS SCP = SFalse + (%:==) SCS SCQ = SFalse + (%:==) SCS SCR = SFalse + (%:==) SCS SCS = STrue + (%:==) SCS SCT = SFalse + (%:==) SCS SCU = SFalse + (%:==) SCS SCV = SFalse + (%:==) SCS SCW = SFalse + (%:==) SCS SCX = SFalse + (%:==) SCS SCY = SFalse + (%:==) SCS SCZ = SFalse + (%:==) SCT SCA = SFalse + (%:==) SCT SCB = SFalse + (%:==) SCT SCC = SFalse + (%:==) SCT SCD = SFalse + (%:==) SCT SCE = SFalse + (%:==) SCT SCF = SFalse + (%:==) SCT SCG = SFalse + (%:==) SCT SCH = SFalse + (%:==) SCT SCI = SFalse + (%:==) SCT SCJ = SFalse + (%:==) SCT SCK = SFalse + (%:==) SCT SCL = SFalse + (%:==) SCT SCM = SFalse + (%:==) SCT SCN = SFalse + (%:==) SCT SCO = SFalse + (%:==) SCT SCP = SFalse + (%:==) SCT SCQ = SFalse + (%:==) SCT SCR = SFalse + (%:==) SCT SCS = SFalse + (%:==) SCT SCT = STrue + (%:==) SCT SCU = SFalse + (%:==) SCT SCV = SFalse + (%:==) SCT SCW = SFalse + (%:==) SCT SCX = SFalse + (%:==) SCT SCY = SFalse + (%:==) SCT SCZ = SFalse + (%:==) SCU SCA = SFalse + (%:==) SCU SCB = SFalse + (%:==) SCU SCC = SFalse + (%:==) SCU SCD = SFalse + (%:==) SCU SCE = SFalse + (%:==) SCU SCF = SFalse + (%:==) SCU SCG = SFalse + (%:==) SCU SCH = SFalse + (%:==) SCU SCI = SFalse + (%:==) SCU SCJ = SFalse + (%:==) SCU SCK = SFalse + (%:==) SCU SCL = SFalse + (%:==) SCU SCM = SFalse + (%:==) SCU SCN = SFalse + (%:==) SCU SCO = SFalse + (%:==) SCU SCP = SFalse + (%:==) SCU SCQ = SFalse + (%:==) SCU SCR = SFalse + (%:==) SCU SCS = SFalse + (%:==) SCU SCT = SFalse + (%:==) SCU SCU = STrue + (%:==) SCU SCV = SFalse + (%:==) SCU SCW = SFalse + (%:==) SCU SCX = SFalse + (%:==) SCU SCY = SFalse + (%:==) SCU SCZ = SFalse + (%:==) SCV SCA = SFalse + (%:==) SCV SCB = SFalse + (%:==) SCV SCC = SFalse + (%:==) SCV SCD = SFalse + (%:==) SCV SCE = SFalse + (%:==) SCV SCF = SFalse + (%:==) SCV SCG = SFalse + (%:==) SCV SCH = SFalse + (%:==) SCV SCI = SFalse + (%:==) SCV SCJ = SFalse + (%:==) SCV SCK = SFalse + (%:==) SCV SCL = SFalse + (%:==) SCV SCM = SFalse + (%:==) SCV SCN = SFalse + (%:==) SCV SCO = SFalse + (%:==) SCV SCP = SFalse + (%:==) SCV SCQ = SFalse + (%:==) SCV SCR = SFalse + (%:==) SCV SCS = SFalse + (%:==) SCV SCT = SFalse + (%:==) SCV SCU = SFalse + (%:==) SCV SCV = STrue + (%:==) SCV SCW = SFalse + (%:==) SCV SCX = SFalse + (%:==) SCV SCY = SFalse + (%:==) SCV SCZ = SFalse + (%:==) SCW SCA = SFalse + (%:==) SCW SCB = SFalse + (%:==) SCW SCC = SFalse + (%:==) SCW SCD = SFalse + (%:==) SCW SCE = SFalse + (%:==) SCW SCF = SFalse + (%:==) SCW SCG = SFalse + (%:==) SCW SCH = SFalse + (%:==) SCW SCI = SFalse + (%:==) SCW SCJ = SFalse + (%:==) SCW SCK = SFalse + (%:==) SCW SCL = SFalse + (%:==) SCW SCM = SFalse + (%:==) SCW SCN = SFalse + (%:==) SCW SCO = SFalse + (%:==) SCW SCP = SFalse + (%:==) SCW SCQ = SFalse + (%:==) SCW SCR = SFalse + (%:==) SCW SCS = SFalse + (%:==) SCW SCT = SFalse + (%:==) SCW SCU = SFalse + (%:==) SCW SCV = SFalse + (%:==) SCW SCW = STrue + (%:==) SCW SCX = SFalse + (%:==) SCW SCY = SFalse + (%:==) SCW SCZ = SFalse + (%:==) SCX SCA = SFalse + (%:==) SCX SCB = SFalse + (%:==) SCX SCC = SFalse + (%:==) SCX SCD = SFalse + (%:==) SCX SCE = SFalse + (%:==) SCX SCF = SFalse + (%:==) SCX SCG = SFalse + (%:==) SCX SCH = SFalse + (%:==) SCX SCI = SFalse + (%:==) SCX SCJ = SFalse + (%:==) SCX SCK = SFalse + (%:==) SCX SCL = SFalse + (%:==) SCX SCM = SFalse + (%:==) SCX SCN = SFalse + (%:==) SCX SCO = SFalse + (%:==) SCX SCP = SFalse + (%:==) SCX SCQ = SFalse + (%:==) SCX SCR = SFalse + (%:==) SCX SCS = SFalse + (%:==) SCX SCT = SFalse + (%:==) SCX SCU = SFalse + (%:==) SCX SCV = SFalse + (%:==) SCX SCW = SFalse + (%:==) SCX SCX = STrue + (%:==) SCX SCY = SFalse + (%:==) SCX SCZ = SFalse + (%:==) SCY SCA = SFalse + (%:==) SCY SCB = SFalse + (%:==) SCY SCC = SFalse + (%:==) SCY SCD = SFalse + (%:==) SCY SCE = SFalse + (%:==) SCY SCF = SFalse + (%:==) SCY SCG = SFalse + (%:==) SCY SCH = SFalse + (%:==) SCY SCI = SFalse + (%:==) SCY SCJ = SFalse + (%:==) SCY SCK = SFalse + (%:==) SCY SCL = SFalse + (%:==) SCY SCM = SFalse + (%:==) SCY SCN = SFalse + (%:==) SCY SCO = SFalse + (%:==) SCY SCP = SFalse + (%:==) SCY SCQ = SFalse + (%:==) SCY SCR = SFalse + (%:==) SCY SCS = SFalse + (%:==) SCY SCT = SFalse + (%:==) SCY SCU = SFalse + (%:==) SCY SCV = SFalse + (%:==) SCY SCW = SFalse + (%:==) SCY SCX = SFalse + (%:==) SCY SCY = STrue + (%:==) SCY SCZ = SFalse + (%:==) SCZ SCA = SFalse + (%:==) SCZ SCB = SFalse + (%:==) SCZ SCC = SFalse + (%:==) SCZ SCD = SFalse + (%:==) SCZ SCE = SFalse + (%:==) SCZ SCF = SFalse + (%:==) SCZ SCG = SFalse + (%:==) SCZ SCH = SFalse + (%:==) SCZ SCI = SFalse + (%:==) SCZ SCJ = SFalse + (%:==) SCZ SCK = SFalse + (%:==) SCZ SCL = SFalse + (%:==) SCZ SCM = SFalse + (%:==) SCZ SCN = SFalse + (%:==) SCZ SCO = SFalse + (%:==) SCZ SCP = SFalse + (%:==) SCZ SCQ = SFalse + (%:==) SCZ SCR = SFalse + (%:==) SCZ SCS = SFalse + (%:==) SCZ SCT = SFalse + (%:==) SCZ SCU = SFalse + (%:==) SCZ SCV = SFalse + (%:==) SCZ SCW = SFalse + (%:==) SCZ SCX = SFalse + (%:==) SCZ SCY = SFalse + (%:==) SCZ SCZ = STrue + instance SDecide (KProxy :: KProxy AChar) where + (%~) SCA SCA = Proved Refl + (%~) SCA SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCA SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCB = Proved Refl + (%~) SCB SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCB SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCC = Proved Refl + (%~) SCC SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCC SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCD = Proved Refl + (%~) SCD SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCD SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCE = Proved Refl + (%~) SCE SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCE SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCF = Proved Refl + (%~) SCF SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCF SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCG = Proved Refl + (%~) SCG SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCG SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCH = Proved Refl + (%~) SCH SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCH SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCI = Proved Refl + (%~) SCI SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCI SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCJ = Proved Refl + (%~) SCJ SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCJ SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCK = Proved Refl + (%~) SCK SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCK SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCL = Proved Refl + (%~) SCL SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCL SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCM = Proved Refl + (%~) SCM SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCM SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCN = Proved Refl + (%~) SCN SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCN SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCO = Proved Refl + (%~) SCO SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCO SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCP = Proved Refl + (%~) SCP SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCP SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCQ = Proved Refl + (%~) SCQ SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCQ SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCR = Proved Refl + (%~) SCR SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCR SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCS = Proved Refl + (%~) SCS SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCS SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCT = Proved Refl + (%~) SCT SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCT SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCU = Proved Refl + (%~) SCU SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCU SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCV = Proved Refl + (%~) SCV SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCV SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCW = Proved Refl + (%~) SCW SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCW SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCX = Proved Refl + (%~) SCX SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCX SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCY SCY = Proved Refl + (%~) SCY SCZ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCA + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCB + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCC + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCD + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCE + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCF + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCG + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCH + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCI + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCJ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCK + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCL + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCM + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCN + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCO + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCP + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCQ + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCR + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCS + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCT + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCU + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCV + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCW + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCX + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCY + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SCZ SCZ = Proved Refl + instance SingI CA where + sing = SCA + instance SingI CB where + sing = SCB + instance SingI CC where + sing = SCC + instance SingI CD where + sing = SCD + instance SingI CE where + sing = SCE + instance SingI CF where + sing = SCF + instance SingI CG where + sing = SCG + instance SingI CH where + sing = SCH + instance SingI CI where + sing = SCI + instance SingI CJ where + sing = SCJ + instance SingI CK where + sing = SCK + instance SingI CL where + sing = SCL + instance SingI CM where + sing = SCM + instance SingI CN where + sing = SCN + instance SingI CO where + sing = SCO + instance SingI CP where + sing = SCP + instance SingI CQ where + sing = SCQ + instance SingI CR where + sing = SCR + instance SingI CS where + sing = SCS + instance SingI CT where + sing = SCT + instance SingI CU where + sing = SCU + instance SingI CV where + sing = SCV + instance SingI CW where + sing = SCW + instance SingI CX where + sing = SCX + instance SingI CY where + sing = SCY + instance SingI CZ where + sing = SCZ + data instance Sing (z :: Attribute) + = forall (n :: [AChar]) (n :: U). z ~ Attr n n => + SAttr (Sing n) (Sing n) + type SAttribute (z :: Attribute) = Sing z + instance SingKind (KProxy :: KProxy Attribute) where + type DemoteRep (KProxy :: KProxy Attribute) = Attribute + fromSing (SAttr b b) = Attr (fromSing b) (fromSing b) + toSing (Attr b b) + = case + (toSing b :: SomeSing (KProxy :: KProxy [AChar]), + toSing b :: SomeSing (KProxy :: KProxy U)) + of { + (SomeSing c, SomeSing c) -> SomeSing (SAttr c c) } + instance (SingI n, SingI n) => + SingI (Attr (n :: [AChar]) (n :: U)) where + sing = SAttr sing sing + data instance Sing (z :: Schema) + = forall (n :: [Attribute]). z ~ Sch n => SSch (Sing n) + type SSchema (z :: Schema) = Sing z + instance SingKind (KProxy :: KProxy Schema) where + type DemoteRep (KProxy :: KProxy Schema) = Schema + fromSing (SSch b) = Sch (fromSing b) + toSing (Sch b) + = case toSing b :: SomeSing (KProxy :: KProxy [Attribute]) of { + SomeSing c -> SomeSing (SSch c) } + instance SingI n => SingI (Sch (n :: [Attribute])) where + sing = SSch sing + sAppend :: + forall (t :: Schema) (t :: Schema). + Sing t -> Sing t -> Sing (Append t t) + sAppend (SSch s1) (SSch s2) = SSch ((%:++) s1 s2) + sAttrNotIn :: + forall (t :: Attribute) (t :: Schema). + Sing t -> Sing t -> Sing (AttrNotIn t t) + sAttrNotIn _ (SSch SNil) = STrue + sAttrNotIn (SAttr name u) (SSch (SCons (SAttr name' _) t)) + = (%:&&) ((%:/=) name name') (sAttrNotIn (SAttr name u) (SSch t)) + sDisjoint :: + forall (t :: Schema) (t :: Schema). + Sing t -> Sing t -> Sing (Disjoint t t) + sDisjoint (SSch SNil) _ = STrue + sDisjoint (SSch (SCons h t)) s + = (%:&&) (sAttrNotIn h s) (sDisjoint (SSch t) s) + sOccurs :: + forall (t :: [AChar]) (t :: Schema). + Sing t -> Sing t -> Sing (Occurs t t) + sOccurs _ (SSch SNil) = SFalse + sOccurs name (SSch (SCons (SAttr name' _) attrs)) + = (%:||) ((%:==) name name') (sOccurs name (SSch attrs)) + sLookup :: + forall (t :: [AChar]) (t :: Schema). + Sing t -> Sing t -> Sing (Lookup t t) + sLookup _ (SSch SNil) = undefined + sLookup name (SSch (SCons (SAttr name' u) attrs)) + = sIf ((%:==) name name') u (sLookup name (SSch attrs)) +GradingClient/Database.hs:0:0: Splicing declarations + return [] ======> GradingClient/Database.hs:0:0: +GradingClient/Database.hs:(0,0)-(0,0): Splicing expression + cases ''Row [| r |] [| changeId (n ++ (getId r)) r |] + ======> + case r of { + EmptyRow _ -> changeId (n ++ (getId r)) r + ConsRow _ _ -> changeId (n ++ (getId r)) r } diff --git a/tests/compile-and-dump/GradingClient/Database.hs b/tests/compile-and-dump/GradingClient/Database.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/GradingClient/Database.hs @@ -0,0 +1,536 @@ +{- Database.hs + +(c) Richard Eisenberg 2012 +eir@cis.upenn.edu + +This file contains the full code for the database interface example +presented in /Dependently typed programming with singletons/ + +-} + +{-# LANGUAGE PolyKinds, DataKinds, TemplateHaskell, TypeFamilies, + GADTs, TypeOperators, RankNTypes, FlexibleContexts, UndecidableInstances, + FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, + OverlappingInstances, ConstraintKinds, CPP #-} + +-- The OverlappingInstances is needed only to allow the InC and SubsetC classes. +-- This is simply a convenience so that GHC can infer the necessary proofs of +-- schema inclusion. The library could easily be designed without this flag, +-- but it would require a client to explicity build proof terms from +-- InProof and Subset. + +module GradingClient.Database where + +import Prelude hiding ( tail, id ) +import Data.Singletons.TH +import Data.Singletons.Prelude +import Control.Monad +import Data.List hiding ( tail ) +import Control.Monad.Error + +$(singletons [d| + -- Basic Nat type + data Nat = Zero | Succ Nat deriving (Eq, Ord) + |]) + +-- Conversions to any from Integers +fromNat :: Nat -> Integer +fromNat Zero = 0 +fromNat (Succ n) = (fromNat n) + 1 + +toNat :: Integer -> Nat +toNat 0 = Zero +toNat n | n > 0 = Succ (toNat (n - 1)) +toNat _ = error "Converting negative to Nat" + +-- Display and read Nats using decimal digits +instance Show Nat where + show = show . fromNat +instance Read Nat where + readsPrec n s = map (\(a,rest) -> (toNat a,rest)) $ readsPrec n s + +$(singletons [d| + -- Our "U"niverse of types. These types can be stored in our database. + data U = BOOL + | STRING + | NAT + | VEC U Nat deriving (Read, Eq, Show) + + -- A re-definition of Char as an algebraic data type. + -- This is necessary to allow for promotion and type-level Strings. + data AChar = CA | CB | CC | CD | CE | CF | CG | CH | CI + | CJ | CK | CL | CM | CN | CO | CP | CQ | CR + | CS | CT | CU | CV | CW | CX | CY | CZ + deriving (Read, Show, Eq) + + -- A named attribute in our database + data Attribute = Attr [AChar] U + + -- A schema is an ordered list of named attributes + data Schema = Sch [Attribute] + + -- append two schemas + append :: Schema -> Schema -> Schema + append (Sch s1) (Sch s2) = Sch (s1 ++ s2) + + -- predicate to check that a schema is free of a certain attribute + attrNotIn :: Attribute -> Schema -> Bool + attrNotIn _ (Sch []) = True + attrNotIn (Attr name u) (Sch ((Attr name' _) : t)) = + (name /= name') && (attrNotIn (Attr name u) (Sch t)) + + -- predicate to check that two schemas are disjoint + disjoint :: Schema -> Schema -> Bool + disjoint (Sch []) _ = True + disjoint (Sch (h : t)) s = (attrNotIn h s) && (disjoint (Sch t) s) + + -- predicate to check if a name occurs in a schema + occurs :: [AChar] -> Schema -> Bool + occurs _ (Sch []) = False + occurs name (Sch ((Attr name' _) : attrs)) = + name == name' || occurs name (Sch attrs) + + -- looks up an element type from a schema + lookup :: [AChar] -> Schema -> U + lookup _ (Sch []) = undefined + lookup name (Sch ((Attr name' u) : attrs)) = + if name == name' then u else lookup name (Sch attrs) + |]) + +-- The El type family gives us the type associated with a constructor +-- of U: +type family El (u :: U) :: * +type instance El BOOL = Bool +type instance El STRING = String +type instance El NAT = Nat +type instance El (VEC u n) = Vec (El u) n + +-- Length-indexed vectors +data Vec :: * -> Nat -> * where + VNil :: Vec a Zero + VCons :: a -> Vec a n -> Vec a (Succ n) + +-- Read instances are keyed by the index of the vector to aid in parsing +instance Read (Vec a Zero) where + readsPrec _ s = [(VNil, s)] +instance (Read a, Read (Vec a n)) => Read (Vec a (Succ n)) where + readsPrec n s = do + (a, rest) <- readsPrec n s + (tail, restrest) <- readsPrec n rest + return (VCons a tail, restrest) + +-- Because the Read instances are keyed by the length of the vector, +-- it is not obvious to the compiler that all Vecs have a Read instance. +-- We must make a short inductive proof of this fact. + +-- First, we define a datatype to store the resulting instance, keyed +-- by the parameters to Vec: +data VecReadInstance a n where + VecReadInstance :: Read (Vec a n) => VecReadInstance a n + +-- Then, we make a function that produces an instance of Read for a +-- Vec, given the datatype it is over and its length, both encoded +-- using singleton types: +vecReadInstance :: Read (El u) => SU u -> SNat n -> VecReadInstance (El u) n +vecReadInstance _ SZero = VecReadInstance +vecReadInstance u (SSucc n) = case vecReadInstance u n of + VecReadInstance -> VecReadInstance + +-- The Show instance can be straightforwardly defined: +instance Show a => Show (Vec a n) where + show VNil = "" + show (VCons h t) = (show h) ++ " " ++ (show t) + +-- We need to be able to Read and Show elements of our database, so +-- we must know that any type of the form (El u) for some (u :: U) +-- has a Read and Show instance. Because we can't declare this instance +-- directly (as, in general, declaring an instance of a type family +-- would be unsound), we provide inductive proofs that these instances +-- exist: +data ElUReadInstance u where + ElUReadInstance :: Read (El u) => ElUReadInstance u + +elUReadInstance :: Sing u -> ElUReadInstance u +elUReadInstance SBOOL = ElUReadInstance +elUReadInstance SSTRING = ElUReadInstance +elUReadInstance SNAT = ElUReadInstance +elUReadInstance (SVEC u n) = case elUReadInstance u of + ElUReadInstance -> case vecReadInstance u n of + VecReadInstance -> ElUReadInstance + +data ElUShowInstance u where + ElUShowInstance :: Show (El u) => ElUShowInstance u + +elUShowInstance :: Sing u -> ElUShowInstance u +elUShowInstance SBOOL = ElUShowInstance +elUShowInstance SSTRING = ElUShowInstance +elUShowInstance SNAT = ElUShowInstance +elUShowInstance (SVEC u _) = case elUShowInstance u of + ElUShowInstance -> ElUShowInstance + +showAttrProof :: Sing (Attr nm u) -> ElUShowInstance u +showAttrProof (SAttr _ u) = elUShowInstance u + +-- A Row is one row of our database table, keyed by its schema. +data Row :: Schema -> * where + EmptyRow :: [Int] -> Row (Sch '[]) -- the Ints are the unique id of the row + ConsRow :: El u -> Row (Sch s) -> Row (Sch ((Attr name u) ': s)) + +-- We build Show instances for a Row element by element: +instance Show (Row (Sch '[])) where + show (EmptyRow n) = "(id=" ++ (show n) ++ ")" +instance (Show (El u), Show (Row (Sch attrs))) => + Show (Row (Sch ((Attr name u) ': attrs))) where + show (ConsRow h t) = case t of + EmptyRow n -> (show h) ++ " (id=" ++ (show n) ++ ")" + _ -> (show h) ++ ", " ++ (show t) + +-- A Handle in our system is an abstract handle to a loaded table. +-- The constructor is not exported. In our simplistic case, we +-- just store the list of rows. A more sophisticated implementation +-- could store some identifier to the connection to an external database. +data Handle :: Schema -> * where + Handle :: [Row s] -> Handle s + +-- The following functions parse our very simple flat file database format. + +-- The file, with a name ending in ".dat", consists of a sequence of lines, +-- where each line contains one entry in the table. There is no row separator; +-- if a row contains n pieces of data, that row is represented in n lines in +-- the file. + +-- A schema is stored in a file of the same name, except ending in ".schema". +-- Each line in the file is a constructor of U indicating the type of the +-- corresponding row element. + +-- Use Either for error handling in parsing functions +type ErrorM = Either String + +-- This function is relatively uninteresting except for its use of +-- pattern matching to introduce the instances of Read and Show for +-- elements +readRow :: Int -> SSchema s -> [String] -> ErrorM (Row s, [String]) +readRow id (SSch SNil) strs = + return (EmptyRow [id], strs) +readRow _ (SSch (SCons _ _)) [] = + throwError "Ran out of data while processing row" +readRow id (SSch (SCons (SAttr _ u) at)) (sh:st) = do + (rowTail, strTail) <- readRow id (SSch at) st + case elUReadInstance u of + ElUReadInstance -> + let results = readsPrec 0 sh in + if null results + then throwError $ "No parse of " ++ sh ++ " as a " ++ + (show (fromSing u)) + else + let item = fst $ head results in + case elUShowInstance u of + ElUShowInstance -> return (ConsRow item rowTail, strTail) + +readRows :: SSchema s -> [String] -> [Row s] -> ErrorM [Row s] +readRows _ [] soFar = return soFar +readRows sch lst soFar = do + (row, rest) <- readRow (length soFar) sch lst + readRows sch rest (row : soFar) + +-- Given the name of a database and its schema, return a handle to the +-- database. +connect :: String -> SSchema s -> IO (Handle s) +connect name schema = do + schString <- readFile (name ++ ".schema") + let schEntries = lines schString + usFound = map read schEntries -- load schema just using "read" + (Sch attrs) = fromSing schema + usExpected = map (\(Attr _ u) -> u) attrs + unless (usFound == usExpected) -- compare found schema with expected + (fail "Expected schema does not match found schema") + dataString <- readFile (name ++ ".dat") + let dataEntries = lines dataString + result = readRows schema dataEntries [] -- read actual data + case result of + Left errorMsg -> fail errorMsg + Right rows -> return $ Handle rows + +-- In order to define strongly-typed projection from a row, we need to have a notion +-- that one schema is a subset of another. We permit the schemas to have their columns +-- in different orders. We define this subset relation via two inductively defined +-- propositions. In Haskell, these inductively defined propositions take the form of +-- GADTs. In their original form, they would look like this: +{- +data InProof :: Attribute -> Schema -> * where + InElt :: InProof attr (Sch (attr ': schTail)) + InTail :: InProof attr (Sch attrs) -> InProof attr (Sch (a ': attrs)) + +data SubsetProof :: Schema -> Schema -> * where + SubsetEmpty :: SubsetProof (Sch '[]) s' + SubsetCons :: InProof attr s' -> SubsetProof (Sch attrs) s' -> + SubsetProof (Sch (attr ': attrs)) s' +-} +-- However, it would be convenient to users of the database library not to require +-- building these proofs manually. So, we define type classes so that the compiler +-- builds the proofs automatically. To make everything work well together, we also +-- make the parameters to the proof GADT constructors implicit -- i.e. in the form +-- of type class constraints. + +data InProof :: Attribute -> Schema -> * where + InElt :: InProof attr (Sch (attr ': schTail)) + InTail :: InC name u (Sch attrs) => InProof (Attr name u) (Sch (a ': attrs)) + +class InC (name :: [AChar]) (u :: U) (sch :: Schema) where + inProof :: InProof (Attr name u) sch +instance InC name u (Sch ((Attr name u) ': schTail)) where + inProof = InElt +instance InC name u (Sch attrs) => InC name u (Sch (a ': attrs)) where + inProof = InTail + +data SubsetProof :: Schema -> Schema -> * where + SubsetEmpty :: SubsetProof (Sch '[]) s' + SubsetCons :: (InC name u s', SubsetC (Sch attrs) s') => + SubsetProof (Sch ((Attr name u) ': attrs)) s' + +class SubsetC (s :: Schema) (s' :: Schema) where + subset :: SubsetProof s s' + +instance SubsetC (Sch '[]) s' where + subset = SubsetEmpty +instance (InC name u s', SubsetC (Sch attrs) s') => + SubsetC (Sch ((Attr name u) ': attrs)) s' where + subset = SubsetCons + +-- To access the data in a structured (and well-typed!) way, we use +-- an RA (short for Relational Algebra). An RA is indexed by the schema +-- of the data it produces. +data RA :: Schema -> * where + -- The RA includes all data represented by the handle. + Read :: Handle s -> RA s + + -- The RA is a union of the rows represented by the two RAs provided. + -- Note that the schemas of the two RAs must be the same for this + -- constructor use to type-check. + Union :: RA s -> RA s -> RA s + + -- The RA is the list of rows in the first RA, omitting those in the + -- second. Once again, the schemas must match. + Diff :: RA s -> RA s -> RA s + + -- The RA is a Cartesian product of the two RAs provided. Note that + -- the schemas of the two provided RAs must be disjoint. + Product :: (Disjoint s s' ~ True, SingI s, SingI s') => + RA s -> RA s' -> RA (Append s s') + + -- The RA is a projection conforming to the schema provided. The + -- type-checker ensures that this schema is a subset of the data + -- included in the provided RA. + Project :: (SubsetC s' s, SingI s) => + SSchema s' -> RA s -> RA s' + + -- The RA contains only those rows of the provided RA for which + -- the provided expression evaluates to True. Note that the + -- schema of the provided RA and the resultant RA are the same + -- because the columns of data are the same. Also note that + -- the expression must return a Bool for this to type-check. + Select :: Expr s BOOL -> RA s -> RA s + +-- Other constructors would be added in a more robust database +-- implementation. + +-- An Expr is used with the Select constructor to choose some +-- subset of rows from a table. Expressions are indexed by the +-- schema over which they operate and the return value they +-- produce. +data Expr :: Schema -> U -> * where + -- Equality among two elements + Equal :: Eq (El u) => Expr s u -> Expr s u -> Expr s BOOL + + -- A less-than comparison among two Nats + LessThan :: Expr s NAT -> Expr s NAT -> Expr s BOOL + + -- A literal number + LiteralNat :: Integer -> Expr s NAT + + -- Projection in an expression -- evaluates to the value + -- of the named attribute. + Element :: (Occurs nm s ~ True) => + SSchema s -> Sing nm -> Expr s (Lookup nm s) + + -- A more robust implementation would include more constructors + +-- Retrieves the id from a row. Ids are used when computing unions and +-- differences. +getId :: Row s -> [Int] +getId (EmptyRow n) = n +getId (ConsRow _ t) = getId t + +-- Changes the id of a row to a new value +changeId :: [Int] -> Row s -> Row s +changeId n (EmptyRow _) = EmptyRow n +changeId n (ConsRow h t) = ConsRow h (changeId n t) + +-- Equality for rows based on ids. +eqRow :: Row s -> Row s -> Bool +eqRow r1 r2 = getId r1 == getId r2 + +-- Equality for attributes based on names +eqAttr :: Attribute -> Attribute -> Bool +eqAttr (Attr nm _) (Attr nm' _) = nm == nm' + +-- Appends two rows. There are three suspicious case statements -- they are +-- suspicious in that the different branches are all exactly identical. Here +-- is why they are needed: + +-- The two case statements on r are necessary to deconstruct the index in the +-- type of r; GHC does not use the fact that s' must be (Sch a') for some a'. +-- By doing a case analysis on r, GHC uses the types given in the different +-- constructors for Row, both of which give the form of s' as (Sch a'). This +-- deconstruction is necessary for the type family Append to compute, because +-- Append is defined only when its second argument is of the form (Sch a'). + +-- The case statement on rowAppend t r is necessary to avoid potential +-- overlapping instances for the SingRep class; the instances are needed for +-- the call to ConsRow. The potential for overlapping instances comes from +-- ambiguity in the component types of (Append s s'). By doing case analysis +-- on rowAppend t r, these variables become fixed, and the potential for +-- overlapping instances disappears. + +-- We use the "cases" Singletons library operation to produce the case +-- analysis in the first clause. This "cases" operation produces a case +-- statement where each branch is identical and each constructor parameter +-- is ignored. The "cases" operation does not work for the second clause +-- because the code in the clause depends on definitions generated earlier. +-- Template Haskell restricts certain dependencies between auto-generated +-- code blocks to prevent the possibility of circular dependencies. +-- In this case, if the $(singletons ...) blocks above were in a different +-- module, the "cases" operation would be applicable here. + +$( return [] ) + +rowAppend :: Row s -> Row s' -> Row (Append s s') +rowAppend (EmptyRow n) r = $(cases ''Row [| r |] + [| changeId (n ++ (getId r)) r |]) +rowAppend (ConsRow h t) r = case r of + EmptyRow _ -> + case rowAppend t r of + EmptyRow _ -> ConsRow h (rowAppend t r) + ConsRow _ _ -> ConsRow h (rowAppend t r) + ConsRow _ _ -> + case rowAppend t r of + EmptyRow _ -> ConsRow h (rowAppend t r) + ConsRow _ _ -> ConsRow h (rowAppend t r) + +-- Choose the elements of one list based on truth values in another +choose :: [Bool] -> [a] -> [a] +choose [] _ = [] +choose (False : btail) (_ : t) = choose btail t +choose (True : btail) (h : t) = h : (choose btail t) +choose _ [] = [] + +-- The query function is the eliminator for an RA. It returns a list of +-- rows containing the data produced by the RA. +query :: forall s. SingI s => RA s -> IO [Row s] +query (Read (Handle rows)) = return rows +query (Union ra rb) = do + rowsa <- query ra + rowsb <- query rb + return $ unionBy eqRow rowsa rowsb +query (Diff ra rb) = do + rowsa <- query ra + rowsb <- query rb + return $ deleteFirstsBy eqRow rowsa rowsb +query (Product ra rb) = do + rowsa <- query ra + rowsb <- query rb + return $ do -- entering the [] Monad + rowa <- rowsa + rowb <- rowsb + return $ rowAppend rowa rowb +query (Project sch ra) = do + rows <- query ra + return $ map (projectRow sch) rows + where -- The projectRow function uses the relationship encoded in the Subset + -- relation to project the requested columns of data in a type-safe manner. + + -- It recurs on the structure of the provided schema, creating the output + -- row to be in the same order as the input schema. This is necessary for + -- the output to type-check, as it is indexed by the input schema. + + -- We use explicit quantification to get access to scoped type variables. + projectRow :: forall (sch :: Schema) (s' :: Schema). + SubsetC sch s' => SSchema sch -> Row s' -> Row sch + + -- Base case: empty schema + projectRow (SSch SNil) r = EmptyRow (getId r) + + -- In the recursive case, we need to pattern-match on the proof that + -- the provided schema is a subset of the provided RA. We extract this + -- proof (of type SubsetProof s s') from the SubsetC instance using the + -- subset method. + projectRow (SSch (SCons attr tail)) r = + case subset :: SubsetProof sch s' of + + -- Because we know that the schema is non-empty, the only possibility + -- here is SubsetCons: + SubsetCons -> + let rtail = projectRow (SSch tail) r in + case attr of + SAttr _ u -> case elUShowInstance u of + ElUShowInstance -> ConsRow (extractElt attr r) rtail + + -- GHC correctly determines that this case is impossible if it is + -- not commented. + -- SubsetEmpty -> undefined <== IMPOSSIBLE + + -- However, the current version of GHC (7.5) does not suppress warnings + -- for incomplete pattern matches when the remaining cases are impossible. + -- So, we include this case (impossible to reach for any terminated value) + -- to suppress the warning. + _ -> error "Type checking failed" + + -- Retrieves the element, looked up by the name of the provided attribute, + -- from a row. The explicit quantification is necessary to create the scoped + -- type variables to use in the return type of <> + extractElt :: forall nm u sch. InC nm u sch => + Sing (Attr nm u) -> Row sch -> El u + extractElt attr r = case inProof :: InProof (Attr nm u) sch of + InElt -> case r of + ConsRow h _ -> h + -- EmptyRow _ -> undefined <== IMPOSSIBLE + _ -> error "Type checking failed" + InTail -> case r of + ConsRow _ t -> extractElt attr t + -- EmptyRow _ -> undefined <== IMPOSSBLE + _ -> error "Type checking failed" + +query (Select expr r) = do + rows <- query r + let vals = map (eval expr) rows + return $ choose vals rows + where -- Evaluates an expression + eval :: forall s' u. SingI s' => Expr s' u -> Row s' -> El u + eval (Element _ (name :: Sing name)) row = + case row of + -- EmptyRow _ -> undefined <== IMPOSSIBLE + ConsRow h t -> case row of + (ConsRow _ _ :: Row (Sch ((Attr name' u') ': attrs))) -> + case sing :: Sing s' of + -- SSch SNil -> undefined <== IMPOSSIBLE + SSch (SCons (SAttr name' _) stail) -> + case name %:== name' of + STrue -> h + SFalse -> withSingI stail (eval (Element (SSch stail) name) t) + _ -> bugInGHC + _ -> bugInGHC + + eval (Equal (e1 :: Expr s' u') e2) row = + let v1 = eval e1 row + v2 = eval e2 row in + v1 == v2 + + -- Note that the types really help us here: the LessThan constructor is + -- defined only over Expr s NAT, so we know that evaluating e1 and e2 will + -- yield Nats, which are a member of the Ord type class. + eval (LessThan e1 e2) row = + let v1 = eval e1 row + v2 = eval e2 row in + v1 < v2 + + eval (LiteralNat x) _ = toNat x diff --git a/tests/compile-and-dump/GradingClient/Main.ghc76.template b/tests/compile-and-dump/GradingClient/Main.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/GradingClient/Main.ghc76.template @@ -0,0 +1,75 @@ +GradingClient/Main.hs:0:0: Splicing declarations + singletons + [d| lastName, majorName, gradeName, yearName, firstName :: [AChar] + lastName = [CL, CA, CS, CT] + firstName = [CF, CI, CR, CS, CT] + yearName = [CY, CE, CA, CR] + gradeName = [CG, CR, CA, CD, CE] + majorName = [CM, CA, CJ, CO, CR] + gradingSchema :: Schema + gradingSchema + = Sch + [Attr lastName STRING, Attr firstName STRING, Attr yearName NAT, + Attr gradeName NAT, Attr majorName BOOL] + names :: Schema + names = Sch [Attr firstName STRING, Attr lastName STRING] |] + ======> + GradingClient/Main.hs:(0,0)-(0,0) + lastName :: [AChar] + majorName :: [AChar] + gradeName :: [AChar] + yearName :: [AChar] + firstName :: [AChar] + lastName = [CL, CA, CS, CT] + firstName = [CF, CI, CR, CS, CT] + yearName = [CY, CE, CA, CR] + gradeName = [CG, CR, CA, CD, CE] + majorName = [CM, CA, CJ, CO, CR] + gradingSchema :: Schema + gradingSchema + = Sch + [Attr lastName STRING, Attr firstName STRING, Attr yearName NAT, + Attr gradeName NAT, Attr majorName BOOL] + names :: Schema + names = Sch [Attr firstName STRING, Attr lastName STRING] + type LastName = '[CL, CA, CS, CT] + type FirstName = '[CF, CI, CR, CS, CT] + type YearName = '[CY, CE, CA, CR] + type GradeName = '[CG, CR, CA, CD, CE] + type MajorName = '[CM, CA, CJ, CO, CR] + type GradingSchema = + Sch '[Attr LastName STRING, + Attr FirstName STRING, + Attr YearName NAT, + Attr GradeName NAT, + Attr MajorName BOOL] + type Names = Sch '[Attr FirstName STRING, Attr LastName STRING] + sLastName :: Sing LastName + sMajorName :: Sing MajorName + sGradeName :: Sing GradeName + sYearName :: Sing YearName + sFirstName :: Sing FirstName + sLastName = SCons SCL (SCons SCA (SCons SCS (SCons SCT SNil))) + sFirstName + = SCons SCF (SCons SCI (SCons SCR (SCons SCS (SCons SCT SNil)))) + sYearName = SCons SCY (SCons SCE (SCons SCA (SCons SCR SNil))) + sGradeName + = SCons SCG (SCons SCR (SCons SCA (SCons SCD (SCons SCE SNil)))) + sMajorName + = SCons SCM (SCons SCA (SCons SCJ (SCons SCO (SCons SCR SNil)))) + sGradingSchema :: Sing GradingSchema + sGradingSchema + = SSch + (SCons + (SAttr sLastName SSTRING) + (SCons + (SAttr sFirstName SSTRING) + (SCons + (SAttr sYearName SNAT) + (SCons + (SAttr sGradeName SNAT) (SCons (SAttr sMajorName SBOOL) SNil))))) + sNames :: Sing Names + sNames + = SSch + (SCons + (SAttr sFirstName SSTRING) (SCons (SAttr sLastName SSTRING) SNil)) diff --git a/tests/compile-and-dump/GradingClient/Main.ghc78.template b/tests/compile-and-dump/GradingClient/Main.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/GradingClient/Main.ghc78.template @@ -0,0 +1,75 @@ +GradingClient/Main.hs:0:0: Splicing declarations + singletons + [d| lastName, majorName, gradeName, yearName, firstName :: [AChar] + lastName = [CL, CA, CS, CT] + firstName = [CF, CI, CR, CS, CT] + yearName = [CY, CE, CA, CR] + gradeName = [CG, CR, CA, CD, CE] + majorName = [CM, CA, CJ, CO, CR] + gradingSchema :: Schema + gradingSchema + = Sch + [Attr lastName STRING, Attr firstName STRING, Attr yearName NAT, + Attr gradeName NAT, Attr majorName BOOL] + names :: Schema + names = Sch [Attr firstName STRING, Attr lastName STRING] |] + ======> + GradingClient/Main.hs:(0,0)-(0,0) + lastName :: [AChar] + majorName :: [AChar] + gradeName :: [AChar] + yearName :: [AChar] + firstName :: [AChar] + lastName = [CL, CA, CS, CT] + firstName = [CF, CI, CR, CS, CT] + yearName = [CY, CE, CA, CR] + gradeName = [CG, CR, CA, CD, CE] + majorName = [CM, CA, CJ, CO, CR] + gradingSchema :: Schema + gradingSchema + = Sch + [Attr lastName STRING, Attr firstName STRING, Attr yearName NAT, + Attr gradeName NAT, Attr majorName BOOL] + names :: Schema + names = Sch [Attr firstName STRING, Attr lastName STRING] + type LastName = '[CL, CA, CS, CT] + type FirstName = '[CF, CI, CR, CS, CT] + type YearName = '[CY, CE, CA, CR] + type GradeName = '[CG, CR, CA, CD, CE] + type MajorName = '[CM, CA, CJ, CO, CR] + type GradingSchema = + Sch '[Attr LastName STRING, + Attr FirstName STRING, + Attr YearName NAT, + Attr GradeName NAT, + Attr MajorName BOOL] + type Names = Sch '[Attr FirstName STRING, Attr LastName STRING] + sLastName :: Sing LastName + sMajorName :: Sing MajorName + sGradeName :: Sing GradeName + sYearName :: Sing YearName + sFirstName :: Sing FirstName + sLastName = SCons SCL (SCons SCA (SCons SCS (SCons SCT SNil))) + sFirstName + = SCons SCF (SCons SCI (SCons SCR (SCons SCS (SCons SCT SNil)))) + sYearName = SCons SCY (SCons SCE (SCons SCA (SCons SCR SNil))) + sGradeName + = SCons SCG (SCons SCR (SCons SCA (SCons SCD (SCons SCE SNil)))) + sMajorName + = SCons SCM (SCons SCA (SCons SCJ (SCons SCO (SCons SCR SNil)))) + sGradingSchema :: Sing GradingSchema + sGradingSchema + = SSch + (SCons + (SAttr sLastName SSTRING) + (SCons + (SAttr sFirstName SSTRING) + (SCons + (SAttr sYearName SNAT) + (SCons + (SAttr sGradeName SNAT) (SCons (SAttr sMajorName SBOOL) SNil))))) + sNames :: Sing Names + sNames + = SSch + (SCons + (SAttr sFirstName SSTRING) (SCons (SAttr sLastName SSTRING) SNil)) diff --git a/tests/compile-and-dump/GradingClient/Main.hs b/tests/compile-and-dump/GradingClient/Main.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/GradingClient/Main.hs @@ -0,0 +1,53 @@ +{- GradingClient.hs + +(c) Richard Eisenberg 2012 +eir@cis.upenn.edu + +This file accesses the database described in Database.hs and performs +some basic queries on it. + +-} + +{-# LANGUAGE TemplateHaskell, DataKinds #-} + +module Main where + +import Data.Singletons.TH +import Data.Singletons.List +import GradingClient.Database + +$(singletons [d| + lastName, firstName, yearName, gradeName, majorName :: [AChar] + lastName = [CL, CA, CS, CT] + firstName = [CF, CI, CR, CS, CT] + yearName = [CY, CE, CA, CR] + gradeName = [CG, CR, CA, CD, CE] + majorName = [CM, CA, CJ, CO, CR] + + gradingSchema :: Schema + gradingSchema = Sch [Attr lastName STRING, + Attr firstName STRING, + Attr yearName NAT, + Attr gradeName NAT, + Attr majorName BOOL] + + names :: Schema + names = Sch [Attr firstName STRING, + Attr lastName STRING] + |]) + +main :: IO () +main = do + h <- connect "grades" sGradingSchema + let ra = Read h + + allStudents <- query $ Project sNames ra + putStrLn $ "Names of all students: " ++ (show allStudents) ++ "\n" + + majors <- query $ Select (Element sGradingSchema sMajorName) ra + putStrLn $ "Students in major: " ++ (show majors) ++ "\n" + + b_students <- + query $ Project sNames $ + Select (LessThan (Element sGradingSchema sGradeName) (LiteralNat 90)) ra + putStrLn $ "Names of students with grade < 90: " ++ (show b_students) ++ "\n" diff --git a/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc76.template b/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc76.template @@ -0,0 +1,77 @@ +InsertionSort/InsertionSortImp.hs:0:0: Splicing declarations + singletons [d| data Nat = Zero | Succ Nat |] + ======> + InsertionSort/InsertionSortImp.hs:(0,0)-(0,0) + data Nat = Zero | Succ Nat + data instance Sing (z :: Nat) + = z ~ Zero => SZero | + forall (n :: Nat). z ~ Succ n => SSucc (Sing n) + type SNat (z :: Nat) = Sing z + instance SingKind (KProxy :: KProxy Nat) where + type instance DemoteRep (KProxy :: KProxy Nat) = Nat + fromSing SZero = Zero + fromSing (SSucc b) = Succ (fromSing b) + toSing Zero = SomeSing SZero + toSing (Succ b) + = case toSing b :: SomeSing (KProxy :: KProxy Nat) of { + SomeSing c -> SomeSing (SSucc c) } + instance SingI Zero where + sing = SZero + instance SingI n => SingI (Succ (n :: Nat)) where + sing = SSucc sing +InsertionSort/InsertionSortImp.hs:0:0: Splicing declarations + singletons + [d| leq :: Nat -> Nat -> Bool + leq Zero _ = True + leq (Succ _) Zero = False + leq (Succ a) (Succ b) = leq a b + insert :: Nat -> [Nat] -> [Nat] + insert n [] = [n] + insert n (h : t) + = if leq n h then (n : h : t) else h : (insert n t) + insertionSort :: [Nat] -> [Nat] + insertionSort [] = [] + insertionSort (h : t) = insert h (insertionSort t) |] + ======> + InsertionSort/InsertionSortImp.hs:(0,0)-(0,0) + leq :: Nat -> Nat -> Bool + leq Zero _ = True + leq (Succ _) Zero = False + leq (Succ a) (Succ b) = leq a b + insert :: Nat -> [Nat] -> [Nat] + insert n GHC.Types.[] = [n] + insert n (h GHC.Types.: t) + = if leq n h then + (n GHC.Types.: (h GHC.Types.: t)) + else + (h GHC.Types.: (insert n t)) + insertionSort :: [Nat] -> [Nat] + insertionSort GHC.Types.[] = GHC.Types.[] + insertionSort (h GHC.Types.: t) = insert h (insertionSort t) + type instance Leq Zero z = True + type instance Leq (Succ z) Zero = False + type instance Leq (Succ a) (Succ b) = Leq a b + type instance Insert n GHC.Types.[] = '[n] + type instance Insert n (GHC.Types.: h t) = + If (Leq n h) (GHC.Types.: n (GHC.Types.: h t)) (GHC.Types.: h (Insert n t)) + type instance InsertionSort GHC.Types.[] = GHC.Types.[] + type instance InsertionSort (GHC.Types.: h t) = + Insert h (InsertionSort t) + type family Leq (a :: Nat) (a :: Nat) :: Bool + type family Insert (a :: Nat) (a :: [Nat]) :: [Nat] + type family InsertionSort (a :: [Nat]) :: [Nat] + sLeq :: + forall (t :: Nat) (t :: Nat). Sing t -> Sing t -> Sing (Leq t t) + sLeq SZero _ = STrue + sLeq (SSucc _) SZero = SFalse + sLeq (SSucc a) (SSucc b) = sLeq a b + sInsert :: + forall (t :: Nat) (t :: [Nat]). + Sing t -> Sing t -> Sing (Insert t t) + sInsert n SNil = SCons n SNil + sInsert n (SCons h t) + = sIf (sLeq n h) (SCons n (SCons h t)) (SCons h (sInsert n t)) + sInsertionSort :: + forall (t :: [Nat]). Sing t -> Sing (InsertionSort t) + sInsertionSort SNil = SNil + sInsertionSort (SCons h t) = sInsert h (sInsertionSort t) diff --git a/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc78.template b/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc78.template @@ -0,0 +1,75 @@ +InsertionSort/InsertionSortImp.hs:0:0: Splicing declarations + singletons [d| data Nat = Zero | Succ Nat |] + ======> + InsertionSort/InsertionSortImp.hs:(0,0)-(0,0) + data Nat = Zero | Succ Nat + data instance Sing (z :: Nat) + = z ~ Zero => SZero | + forall (n :: Nat). z ~ Succ n => SSucc (Sing n) + type SNat (z :: Nat) = Sing z + instance SingKind (KProxy :: KProxy Nat) where + type DemoteRep (KProxy :: KProxy Nat) = Nat + fromSing SZero = Zero + fromSing (SSucc b) = Succ (fromSing b) + toSing Zero = SomeSing SZero + toSing (Succ b) + = case toSing b :: SomeSing (KProxy :: KProxy Nat) of { + SomeSing c -> SomeSing (SSucc c) } + instance SingI Zero where + sing = SZero + instance SingI n => SingI (Succ (n :: Nat)) where + sing = SSucc sing +InsertionSort/InsertionSortImp.hs:0:0: Splicing declarations + singletons + [d| leq :: Nat -> Nat -> Bool + leq Zero _ = True + leq (Succ _) Zero = False + leq (Succ a) (Succ b) = leq a b + insert :: Nat -> [Nat] -> [Nat] + insert n [] = [n] + insert n (h : t) + = if leq n h then (n : h : t) else h : (insert n t) + insertionSort :: [Nat] -> [Nat] + insertionSort [] = [] + insertionSort (h : t) = insert h (insertionSort t) |] + ======> + InsertionSort/InsertionSortImp.hs:(0,0)-(0,0) + leq :: Nat -> Nat -> Bool + leq Zero _ = True + leq (Succ _) Zero = False + leq (Succ a) (Succ b) = leq a b + insert :: Nat -> [Nat] -> [Nat] + insert n GHC.Types.[] = [n] + insert n (h GHC.Types.: t) + = if leq n h then + (n GHC.Types.: (h GHC.Types.: t)) + else + (h GHC.Types.: (insert n t)) + insertionSort :: [Nat] -> [Nat] + insertionSort GHC.Types.[] = [] + insertionSort (h GHC.Types.: t) = insert h (insertionSort t) + type family Leq (a :: Nat) (a :: Nat) :: Bool where + Leq Zero z = True + Leq (Succ z) Zero = False + Leq (Succ a) (Succ b) = Leq a b + type family Insert (a :: Nat) (a :: [Nat]) :: [Nat] where + Insert n GHC.Types.[] = '[n] + Insert n ((GHC.Types.:) h t) = If (Leq n h) ((GHC.Types.:) n ((GHC.Types.:) h t)) ((GHC.Types.:) h (Insert n t)) + type family InsertionSort (a :: [Nat]) :: [Nat] where + InsertionSort GHC.Types.[] = '[] + InsertionSort ((GHC.Types.:) h t) = Insert h (InsertionSort t) + sLeq :: + forall (t :: Nat) (t :: Nat). Sing t -> Sing t -> Sing (Leq t t) + sLeq SZero _ = STrue + sLeq (SSucc _) SZero = SFalse + sLeq (SSucc a) (SSucc b) = sLeq a b + sInsert :: + forall (t :: Nat) (t :: [Nat]). + Sing t -> Sing t -> Sing (Insert t t) + sInsert n SNil = SCons n SNil + sInsert n (SCons h t) + = sIf (sLeq n h) (SCons n (SCons h t)) (SCons h (sInsert n t)) + sInsertionSort :: + forall (t :: [Nat]). Sing t -> Sing (InsertionSort t) + sInsertionSort SNil = SNil + sInsertionSort (SCons h t) = sInsert h (sInsertionSort t) diff --git a/tests/compile-and-dump/InsertionSort/InsertionSortImp.hs b/tests/compile-and-dump/InsertionSort/InsertionSortImp.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/InsertionSort/InsertionSortImp.hs @@ -0,0 +1,206 @@ +{- InsertionSortImp.hs + +(c) Richard Eisenberg 2012 +eir@cis.upenn.edu + +This file contains an implementation of insertion sort over natural numbers, +along with a Haskell proof that the sort algorithm is correct. The code below +uses a combination of GADTs and class instances to record the progress and +result of the proof. + +Ideally, the GADTs would be defined so that the constructors take no explicit +parameters --- the information would all be encoded in the constraints to the +constructors. However, due to the nature of the permutation relation, a class +instance definition corresponding to the constructor PermIns would require +existentially-quantified type variables (the l2 variable in the declaration of +PermIns). Type variables in an instance constraint but not mentioned in the +instance head are inherently ambiguous. The compiler would never be able to +infer the value of the variables. Thus, it is not possible to make a class +PermutationC analogous to PermutationProof in the way that AscendingC is +analogous to AscendingProof. (Note that it may be possible to fundamentally +rewrite the inductive definition of the permutation relation to avoid +existentially-quantified variables. We have not attempted that here.) + +If there were a way to offer an explicit dictionary when satisfying a constraint, +this problem could be avoided, as the variable in question could be made +unambiguous. + +-} + +{-# LANGUAGE IncoherentInstances #-} + +module InsertionSort.InsertionSortImp where + +import Data.Singletons.TH +import Data.Singletons.Prelude + +-- We use the Dict data type from Edward Kmett's constraints package to be +-- able to return dictionaries from functions +import Data.Constraint + +-- Natural numbers, defined with singleton counterparts +$(singletons [d| + data Nat = Zero | Succ Nat + |]) + +-- convenience functions for testing purposes +toNat :: Int -> Nat +toNat 0 = Zero +toNat n | n > 0 = Succ (toNat (n - 1)) +toNat _ = error "Converting negative to Nat" + +fromNat :: Nat -> Int +fromNat Zero = 0 +fromNat (Succ n) = 1 + (fromNat n) + +-- A less-than-or-equal relation among naturals +class (a :: Nat) :<=: (b :: Nat) +instance Zero :<=: a +instance (a :<=: b) => (Succ a) :<=: (Succ b) + +-- A proof term asserting that a list of naturals is in ascending order +data AscendingProof :: [Nat] -> * where + AscEmpty :: AscendingProof '[] + AscOne :: AscendingProof '[n] + AscCons :: (a :<=: b, AscendingC (b ': rest)) => AscendingProof (a ': b ': rest) + +-- The class constraint (implicit parameter definition) corresponding to +-- AscendingProof +class AscendingC (lst :: [Nat]) where + ascendingProof :: AscendingProof lst + +-- The instances correspond to the constructors of AscendingProof +instance AscendingC '[] where + ascendingProof = AscEmpty +instance AscendingC '[n] where + ascendingProof = AscOne +instance (a :<=: b, AscendingC (b ': rest)) => AscendingC (a ': b ': rest) where + ascendingProof = AscCons + +-- A proof term asserting that l2 is the list produced when x is inserted +-- (anywhere) into list l1 +data InsertionProof (x :: k) (l1 :: [k]) (l2 :: [k]) where + InsHere :: InsertionProof x l (x ': l) + InsLater :: InsertionC x l1 l2 => InsertionProof x (y ': l1) (y ': l2) + +-- The class constraint corresponding to InsertionProof +class InsertionC (x :: k) (l1 :: [k]) (l2 :: [k]) where + insertionProof :: InsertionProof x l1 l2 + +instance InsertionC x l (x ': l) where + insertionProof = InsHere +instance InsertionC x l1 l2 => InsertionC x (y ': l1) (y ': l2) where + insertionProof = InsLater + +-- A proof term asserting that l1 and l2 are permutations of each other +data PermutationProof (l1 :: [k]) (l2 :: [k]) where + PermId :: PermutationProof l l + PermIns :: InsertionC x l2 l2' => PermutationProof l1 l2 -> + PermutationProof (x ': l1) l2' + +-- Here is the definition of insertion sort about which we will be reasoning: +$(singletons [d| + leq :: Nat -> Nat -> Bool + leq Zero _ = True + leq (Succ _) Zero = False + leq (Succ a) (Succ b) = leq a b + + insert :: Nat -> [Nat] -> [Nat] + insert n [] = [n] + insert n (h:t) = if leq n h then (n:h:t) else h:(insert n t) + + insertionSort :: [Nat] -> [Nat] + insertionSort [] = [] + insertionSort (h:t) = insert h (insertionSort t) + |]) + +-- A lemma that states if sLeq a b is STrue, then (a :<=: b) +-- This is necessary to convert from the boolean definition of <= to the +-- corresponding constraint +sLeq_true__le :: (Leq a b ~ True) => SNat a -> SNat b -> Dict (a :<=: b) +sLeq_true__le a b = case (a, b) of + (SZero, SZero) -> Dict + (SZero, SSucc _) -> Dict + -- (SSucc _, SZero) -> undefined <== IMPOSSIBLE + (SSucc a', SSucc b') -> case sLeq_true__le a' b' of + Dict -> Dict + _ -> error "type checking failed" + +-- A lemma that states if sLeq a b is SFalse, then (b :<=: a) +sLeq_false__nle :: (Leq a b ~ False) => SNat a -> SNat b -> Dict (b :<=: a) +sLeq_false__nle a b = case (a, b) of + -- (SZero, SZero) -> undefined <== IMPOSSIBLE + -- (SZero, SSucc _) -> undefined <== IMPOSSIBLE + (SSucc _, SZero) -> Dict + (SSucc a', SSucc b') -> case sLeq_false__nle a' b' of + Dict -> Dict + _ -> error "type checking failed" + +-- A lemma that states that inserting into an ascending list produces an +-- ascending list +insert_ascending :: forall n lst. + AscendingC lst => SNat n -> SList lst -> Dict (AscendingC (Insert n lst)) +insert_ascending n lst = + case ascendingProof :: AscendingProof lst of + AscEmpty -> Dict -- If lst is empty, then we're done + AscOne -> case lst of -- If lst has one element... + -- SNil -> undefined <== IMPOSSIBLE + SCons h _ -> case sLeq n h of -- then check if n is <= h + STrue -> case sLeq_true__le n h of Dict -> Dict -- if so, we're done + SFalse -> case sLeq_false__nle n h of Dict -> Dict -- if not, we're done + _ -> error "type checking failed" + AscCons -> case lst of -- Otherwise, if lst is more than one element... + -- SNil -> undefined <== IMPOSSIBLE + SCons h t -> case sLeq n h of -- then check if n is <= h + STrue -> case sLeq_true__le n h of Dict -> Dict -- if so, we're done + SFalse -> case sLeq_false__nle n h of -- if not, things are harder... + Dict -> case t of -- destruct t: lst is (h : h2 : t2) + -- SNil -> undefined <== IMPOSSIBLE + SCons h2 _ -> case sLeq n h2 of -- is n <= h2? + STrue -> -- if so, we're done + case sLeq_true__le n h2 of Dict -> Dict + SFalse -> -- otherwise, show that (Insert n t) is sorted + case insert_ascending n t of Dict -> Dict -- and we're done + _ -> error "type checking failed" + _ -> error "type checking failed" + +-- A lemma that states that inserting n into lst produces a new list with n +-- inserted into lst. +insert_insertion :: SNat n -> SList lst -> Dict (InsertionC n lst (Insert n lst)) +insert_insertion n lst = + case lst of + SNil -> Dict -- if lst is empty, we're done + SCons h t -> case sLeq n h of -- otherwise, is n <= h? + STrue -> Dict -- if so, we're done + SFalse -> case insert_insertion n t of Dict -> Dict -- otherwise, recur + +-- A lemma that states that the result of an insertion sort is in ascending order +insertionSort_ascending :: SList lst -> Dict (AscendingC (InsertionSort lst)) +insertionSort_ascending lst = case lst of + SNil -> Dict -- if the list is empty, we're done + + -- otherwise, we recur to find that insertionSort on t produces an ascending list, + -- and then we use the fact that inserting into an ascending list produces an + -- ascending list + SCons h t -> case insertionSort_ascending t of + Dict -> case insert_ascending h (sInsertionSort t) of Dict -> Dict + +-- A lemma that states that the result of an insertion sort is a permutation +-- of its input +insertionSort_permutes :: SList lst -> PermutationProof lst (InsertionSort lst) +insertionSort_permutes lst = case lst of + SNil -> PermId -- if the list is empty, we're done + + -- otherwise, we wish to use PermIns. We must know that t is a permutation of + -- the insertion sort of t and that inserting h into the insertion sort of t + -- works correctly: + SCons h t -> + case insert_insertion h (sInsertionSort t) of + Dict -> PermIns (insertionSort_permutes t) + +-- A theorem that states that the insertion sort of a list is both ascending +-- and a permutation of the original +insertionSort_correct :: SList lst -> (Dict (AscendingC (InsertionSort lst)), + PermutationProof lst (InsertionSort lst)) +insertionSort_correct lst = (insertionSort_ascending lst, + insertionSort_permutes lst) diff --git a/tests/compile-and-dump/Promote/NumArgs.ghc76.template b/tests/compile-and-dump/Promote/NumArgs.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/NumArgs.ghc76.template @@ -0,0 +1,10 @@ +Promote/NumArgs.hs:0:0: Splicing declarations + promote + [d| returnFunc :: Nat -> Nat -> Nat + returnFunc _ = Succ |] + ======> + Promote/NumArgs.hs:(0,0)-(0,0) + returnFunc :: Nat -> Nat -> Nat + returnFunc _ = Succ + type instance ReturnFunc z = Succ + type family ReturnFunc (a :: Nat) :: Nat -> Nat diff --git a/tests/compile-and-dump/Promote/NumArgs.ghc78.template b/tests/compile-and-dump/Promote/NumArgs.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/NumArgs.ghc78.template @@ -0,0 +1,10 @@ +Promote/NumArgs.hs:0:0: Splicing declarations + promote + [d| returnFunc :: Nat -> Nat -> Nat + returnFunc _ = Succ |] + ======> + Promote/NumArgs.hs:(0,0)-(0,0) + returnFunc :: Nat -> Nat -> Nat + returnFunc _ = Succ + type family ReturnFunc (a :: Nat) :: Nat -> Nat where + ReturnFunc z = Succ diff --git a/tests/compile-and-dump/Promote/NumArgs.hs b/tests/compile-and-dump/Promote/NumArgs.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/NumArgs.hs @@ -0,0 +1,12 @@ +module Promote.NumArgs where + +import Data.Singletons.TH +import Singletons.Nat + +-- used to test the "num args" feature of promoteDec +-- remove this test once eta-expansion is implemented + +$(promote [d| + returnFunc :: Nat -> Nat -> Nat + returnFunc _ = Succ + |]) diff --git a/tests/compile-and-dump/Promote/PatternMatching.ghc76.template b/tests/compile-and-dump/Promote/PatternMatching.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/PatternMatching.ghc76.template @@ -0,0 +1,65 @@ +Promote/PatternMatching.hs:0:0: Splicing declarations + promote + [d| pr = Pair (Succ Zero) ([Zero]) + complex = Pair (Pair (Just Zero) Zero) False + tuple = (False, Just Zero, True) + aList = [Zero, Succ Zero, Succ (Succ Zero)] + + data Pair a b + = Pair a b + deriving (Show) |] + ======> + Promote/PatternMatching.hs:(0,0)-(0,0) + data Pair a b + = Pair a b + deriving (Show) + pr = Pair (Succ Zero) [Zero] + complex = Pair (Pair (Just Zero) Zero) False + tuple = (False, Just Zero, True) + aList = [Zero, Succ Zero, Succ (Succ Zero)] + type Pr = Pair (Succ Zero) '[Zero] + type Complex = Pair (Pair (Just Zero) Zero) False + type Tuple = '(False, Just Zero, True) + type AList = '[Zero, Succ Zero, Succ (Succ Zero)] +Promote/PatternMatching.hs:0:0: Splicing declarations + promote + [d| Pair sz lz = pr + Pair (Pair jz zz) fls = complex + (tf, tjz, tt) = tuple + [_, lsz, (Succ blimy)] = aList |] + ======> + Promote/PatternMatching.hs:(0,0)-(0,0) + Pair sz lz = pr + Pair (Pair jz zz) fls = complex + (tf, tjz, tt) = tuple + [_, lsz, Succ blimy] = aList + type Sz = Extract_0123456789 Pr + type Lz = Extract_0123456789 Pr + type family Extract_0123456789 (a :: Pair a b) :: a + type family Extract_0123456789 (a :: Pair a b) :: b + type instance Extract_0123456789 (Pair a a) = a + type instance Extract_0123456789 (Pair a a) = a + type Jz = Extract_0123456789 (Extract_0123456789 Complex) + type Zz = Extract_0123456789 (Extract_0123456789 Complex) + type Fls = Extract_0123456789 Complex + type family Extract_0123456789 (a :: Pair a b) :: a + type family Extract_0123456789 (a :: Pair a b) :: b + type instance Extract_0123456789 (Pair a a) = a + type instance Extract_0123456789 (Pair a a) = a + type family Extract_0123456789 (a :: Pair a b) :: a + type family Extract_0123456789 (a :: Pair a b) :: b + type instance Extract_0123456789 (Pair a a) = a + type instance Extract_0123456789 (Pair a a) = a + type Tf = Extract_0123456789 Tuple + type Tjz = Extract_0123456789 Tuple + type Tt = Extract_0123456789 Tuple + type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: a + type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: b + type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: c + type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a + type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a + type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a + type Lsz = Head (Tail AList) + type Blimy = Extract_0123456789 (Head (Tail (Tail AList))) + type family Extract_0123456789 (a :: Nat) :: Nat + type instance Extract_0123456789 (Succ a) = a diff --git a/tests/compile-and-dump/Promote/PatternMatching.ghc78.template b/tests/compile-and-dump/Promote/PatternMatching.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/PatternMatching.ghc78.template @@ -0,0 +1,65 @@ +Promote/PatternMatching.hs:0:0: Splicing declarations + promote + [d| pr = Pair (Succ Zero) ([Zero]) + complex = Pair (Pair (Just Zero) Zero) False + tuple = (False, Just Zero, True) + aList = [Zero, Succ Zero, Succ (Succ Zero)] + + data Pair a b + = Pair a b + deriving (Show) |] + ======> + Promote/PatternMatching.hs:(0,0)-(0,0) + data Pair a b + = Pair a b + deriving (Show) + pr = Pair (Succ Zero) [Zero] + complex = Pair (Pair (Just Zero) Zero) False + tuple = (False, Just Zero, True) + aList = [Zero, Succ Zero, Succ (Succ Zero)] + type Pr = Pair (Succ Zero) '[Zero] + type Complex = Pair (Pair (Just Zero) Zero) False + type Tuple = '(False, Just Zero, True) + type AList = '[Zero, Succ Zero, Succ (Succ Zero)] +Promote/PatternMatching.hs:0:0: Splicing declarations + promote + [d| Pair sz lz = pr + Pair (Pair jz zz) fls = complex + (tf, tjz, tt) = tuple + [_, lsz, (Succ blimy)] = aList |] + ======> + Promote/PatternMatching.hs:(0,0)-(0,0) + Pair sz lz = pr + Pair (Pair jz zz) fls = complex + (tf, tjz, tt) = tuple + [_, lsz, Succ blimy] = aList + type Sz = Extract_0123456789 Pr + type Lz = Extract_0123456789 Pr + type family Extract_0123456789 (a :: Pair a b) :: a + type family Extract_0123456789 (a :: Pair a b) :: b + type instance Extract_0123456789 (Pair a a) = a + type instance Extract_0123456789 (Pair a a) = a + type Jz = Extract_0123456789 (Extract_0123456789 Complex) + type Zz = Extract_0123456789 (Extract_0123456789 Complex) + type Fls = Extract_0123456789 Complex + type family Extract_0123456789 (a :: Pair a b) :: a + type family Extract_0123456789 (a :: Pair a b) :: b + type instance Extract_0123456789 (Pair a a) = a + type instance Extract_0123456789 (Pair a a) = a + type family Extract_0123456789 (a :: Pair a b) :: a + type family Extract_0123456789 (a :: Pair a b) :: b + type instance Extract_0123456789 (Pair a a) = a + type instance Extract_0123456789 (Pair a a) = a + type Tf = Extract_0123456789 Tuple + type Tjz = Extract_0123456789 Tuple + type Tt = Extract_0123456789 Tuple + type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: a + type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: b + type family Extract_0123456789 (a :: GHC.Tuple.(,,) a b c) :: c + type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a + type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a + type instance Extract_0123456789 (GHC.Tuple.(,,) a a a) = a + type Lsz = Head (Tail AList) + type Blimy = Extract_0123456789 (Head (Tail (Tail AList))) + type family Extract_0123456789 (a :: Nat) :: Nat + type instance Extract_0123456789 (Succ a) = a diff --git a/tests/compile-and-dump/Promote/PatternMatching.hs b/tests/compile-and-dump/Promote/PatternMatching.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Promote/PatternMatching.hs @@ -0,0 +1,20 @@ +module Promote.PatternMatching where + +import Data.Singletons.TH +import Data.Singletons.Prelude +import Singletons.Nat + +$(promote [d| + data Pair a b = Pair a b deriving Show + pr = Pair (Succ Zero) ([Zero]) + complex = Pair (Pair (Just Zero) Zero) False + tuple = (False, Just Zero, True) + aList = [Zero, Succ Zero, Succ (Succ Zero)] + |]) + +$(promote [d| + Pair sz lz = pr + Pair (Pair jz zz) fls = complex + (tf, tjz, tt) = tuple + [_, lsz, (Succ blimy)] = aList + |]) diff --git a/tests/compile-and-dump/Singletons/AtPattern.ghc76.template b/tests/compile-and-dump/Singletons/AtPattern.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/AtPattern.ghc76.template @@ -0,0 +1,16 @@ +Singletons/AtPattern.hs:0:0: Splicing declarations + singletons + [d| maybePlus :: Maybe Nat -> Maybe Nat + maybePlus (Just n) = Just (plus (Succ Zero) n) + maybePlus foo@Nothing = foo |] + ======> + Singletons/AtPattern.hs:(0,0)-(0,0) + maybePlus :: Maybe Nat -> Maybe Nat + maybePlus (Just n) = Just (plus (Succ Zero) n) + maybePlus foo@Nothing = foo + type instance MaybePlus (Just n) = Just (Plus (Succ Zero) n) + type instance MaybePlus Nothing = Nothing + type family MaybePlus (a :: Maybe Nat) :: Maybe Nat + sMaybePlus :: forall (t :: Maybe Nat). Sing t -> Sing (MaybePlus t) + sMaybePlus (SJust n) = SJust (sPlus (SSucc SZero) n) + sMaybePlus foo@SNothing = foo diff --git a/tests/compile-and-dump/Singletons/AtPattern.ghc78.template b/tests/compile-and-dump/Singletons/AtPattern.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/AtPattern.ghc78.template @@ -0,0 +1,16 @@ +Singletons/AtPattern.hs:0:0: Splicing declarations + singletons + [d| maybePlus :: Maybe Nat -> Maybe Nat + maybePlus (Just n) = Just (plus (Succ Zero) n) + maybePlus foo@Nothing = foo |] + ======> + Singletons/AtPattern.hs:(0,0)-(0,0) + maybePlus :: Maybe Nat -> Maybe Nat + maybePlus (Just n) = Just (plus (Succ Zero) n) + maybePlus foo@Nothing = foo + type family MaybePlus (a :: Maybe Nat) :: Maybe Nat where + MaybePlus (Just n) = Just (Plus (Succ Zero) n) + MaybePlus Nothing = Nothing + sMaybePlus :: forall (t :: Maybe Nat). Sing t -> Sing (MaybePlus t) + sMaybePlus (SJust n) = SJust (sPlus (SSucc SZero) n) + sMaybePlus foo@SNothing = foo diff --git a/tests/compile-and-dump/Singletons/AtPattern.hs b/tests/compile-and-dump/Singletons/AtPattern.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/AtPattern.hs @@ -0,0 +1,11 @@ +module Singletons.AtPattern where + +import Data.Singletons.TH +import Data.Singletons.Maybe +import Singletons.Nat + +$(singletons [d| + maybePlus :: Maybe Nat -> Maybe Nat + maybePlus (Just n) = Just (plus (Succ Zero) n) + maybePlus foo@Nothing = foo + |]) diff --git a/tests/compile-and-dump/Singletons/BadPlus.ghc76.template b/tests/compile-and-dump/Singletons/BadPlus.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/BadPlus.ghc76.template @@ -0,0 +1,2 @@ +Singletons/BadPlus.hs:0:0: + No type signature for functions: "badPlus"; cannot promote or make singletons. diff --git a/tests/compile-and-dump/Singletons/BadPlus.ghc78.template b/tests/compile-and-dump/Singletons/BadPlus.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/BadPlus.ghc78.template @@ -0,0 +1,2 @@ +Singletons/BadPlus.hs:0:0: + No type signature for functions: "badPlus"; cannot promote or make singletons. diff --git a/tests/compile-and-dump/Singletons/BadPlus.hs b/tests/compile-and-dump/Singletons/BadPlus.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/BadPlus.hs @@ -0,0 +1,11 @@ +module Singletons.BadPlus where + +import Data.Singletons.TH +import Singletons.Nat + +-- Test whether a declaration without type signature is not singletonized. + +$(singletons [d| + badPlus Zero m = m + badPlus (Succ n) m = Succ (plus n m) + |]) diff --git a/tests/compile-and-dump/Singletons/BoxUnBox.ghc76.template b/tests/compile-and-dump/Singletons/BoxUnBox.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/BoxUnBox.ghc76.template @@ -0,0 +1,28 @@ +Singletons/BoxUnBox.hs:0:0: Splicing declarations + singletons + [d| unBox :: Box a -> a + unBox (FBox a) = a + + data Box a = FBox a |] + ======> + Singletons/BoxUnBox.hs:(0,0)-(0,0) + data Box a = FBox a + unBox :: forall a. Box a -> a + unBox (FBox a) = a + type instance UnBox (FBox a) = a + type family UnBox (a :: Box a) :: a + data instance Sing (z :: Box a) + = forall (n :: a). z ~ FBox n => SFBox (Sing n) + type SBox (z :: Box a) = Sing z + instance SingKind (KProxy :: KProxy a) => + SingKind (KProxy :: KProxy (Box a)) where + type instance DemoteRep (KProxy :: KProxy (Box a)) = + Box (DemoteRep (KProxy :: KProxy a)) + fromSing (SFBox b) = FBox (fromSing b) + toSing (FBox b) + = case toSing b :: SomeSing (KProxy :: KProxy a) of { + SomeSing c -> SomeSing (SFBox c) } + instance SingI n => SingI (FBox (n :: a)) where + sing = SFBox sing + sUnBox :: forall (t :: Box a). Sing t -> Sing (UnBox t) + sUnBox (SFBox a) = a diff --git a/tests/compile-and-dump/Singletons/BoxUnBox.ghc78.template b/tests/compile-and-dump/Singletons/BoxUnBox.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/BoxUnBox.ghc78.template @@ -0,0 +1,27 @@ +Singletons/BoxUnBox.hs:0:0: Splicing declarations + singletons + [d| unBox :: Box a -> a + unBox (FBox a) = a + + data Box a = FBox a |] + ======> + Singletons/BoxUnBox.hs:(0,0)-(0,0) + data Box a = FBox a + unBox :: forall a. Box a -> a + unBox (FBox a) = a + type family UnBox (a :: Box a) :: a where + UnBox (FBox a) = a + data instance Sing (z :: Box a) + = forall (n :: a). z ~ FBox n => SFBox (Sing n) + type SBox (z :: Box a) = Sing z + instance SingKind (KProxy :: KProxy a) => + SingKind (KProxy :: KProxy (Box a)) where + type DemoteRep (KProxy :: KProxy (Box a)) = Box (DemoteRep (KProxy :: KProxy a)) + fromSing (SFBox b) = FBox (fromSing b) + toSing (FBox b) + = case toSing b :: SomeSing (KProxy :: KProxy a) of { + SomeSing c -> SomeSing (SFBox c) } + instance SingI n => SingI (FBox (n :: a)) where + sing = SFBox sing + sUnBox :: forall (t :: Box a). Sing t -> Sing (UnBox t) + sUnBox (SFBox a) = a diff --git a/tests/compile-and-dump/Singletons/BoxUnBox.hs b/tests/compile-and-dump/Singletons/BoxUnBox.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/BoxUnBox.hs @@ -0,0 +1,9 @@ +module Singletons.BoxUnBox where + +import Data.Singletons.TH + +$(singletons [d| + data Box a = FBox a + unBox :: Box a -> a + unBox (FBox a) = a + |]) diff --git a/tests/compile-and-dump/Singletons/Contains.ghc76.template b/tests/compile-and-dump/Singletons/Contains.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Contains.ghc76.template @@ -0,0 +1,19 @@ +Singletons/Contains.hs:0:0: Splicing declarations + singletons + [d| contains :: Eq a => a -> [a] -> Bool + contains _ [] = False + contains elt (h : t) = (elt == h) || (contains elt t) |] + ======> + Singletons/Contains.hs:(0,0)-(0,0) + contains :: forall a. Eq a => a -> [a] -> Bool + contains _ GHC.Types.[] = False + contains elt (h GHC.Types.: t) = ((elt == h) || (contains elt t)) + type instance Contains z GHC.Types.[] = False + type instance Contains elt (GHC.Types.: h t) = + :|| (:== elt h) (Contains elt t) + type family Contains (a :: a) (a :: [a]) :: Bool + sContains :: + forall (t :: a) (t :: [a]). SEq (KProxy :: KProxy a) => + Sing t -> Sing t -> Sing (Contains t t) + sContains _ SNil = SFalse + sContains elt (SCons h t) = (%:||) ((%:==) elt h) (sContains elt t) diff --git a/tests/compile-and-dump/Singletons/Contains.ghc78.template b/tests/compile-and-dump/Singletons/Contains.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Contains.ghc78.template @@ -0,0 +1,18 @@ +Singletons/Contains.hs:0:0: Splicing declarations + singletons + [d| contains :: Eq a => a -> [a] -> Bool + contains _ [] = False + contains elt (h : t) = (elt == h) || (contains elt t) |] + ======> + Singletons/Contains.hs:(0,0)-(0,0) + contains :: forall a. Eq a => a -> [a] -> Bool + contains _ GHC.Types.[] = False + contains elt (h GHC.Types.: t) = ((elt == h) || (contains elt t)) + type family Contains (a :: a) (a :: [a]) :: Bool where + Contains z GHC.Types.[] = False + Contains elt ((GHC.Types.:) h t) = (:||) ((:==) elt h) (Contains elt t) + sContains :: + forall (t :: a) (t :: [a]). SEq (KProxy :: KProxy a) => + Sing t -> Sing t -> Sing (Contains t t) + sContains _ SNil = SFalse + sContains elt (SCons h t) = (%:||) ((%:==) elt h) (sContains elt t) diff --git a/tests/compile-and-dump/Singletons/Contains.hs b/tests/compile-and-dump/Singletons/Contains.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Contains.hs @@ -0,0 +1,13 @@ +module Singletons.Contains where + +import Data.Singletons.TH +import Data.Singletons.List +import Data.Singletons.Bool + +-- polimorphic function with context + +$(singletons [d| + contains :: Eq a => a -> [a] -> Bool + contains _ [] = False + contains elt (h:t) = (elt == h) || (contains elt t) + |]) diff --git a/tests/compile-and-dump/Singletons/DataValues.ghc76.template b/tests/compile-and-dump/Singletons/DataValues.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/DataValues.ghc76.template @@ -0,0 +1,46 @@ +Singletons/DataValues.hs:0:0: Splicing declarations + singletons + [d| pr = Pair (Succ Zero) ([Zero]) + complex = Pair (Pair (Just Zero) Zero) False + tuple = (False, Just Zero, True) + aList = [Zero, Succ Zero, Succ (Succ Zero)] + + data Pair a b + = Pair a b + deriving (Show) |] + ======> + Singletons/DataValues.hs:(0,0)-(0,0) + data Pair a b + = Pair a b + deriving (Show) + pr = Pair (Succ Zero) [Zero] + complex = Pair (Pair (Just Zero) Zero) False + tuple = (False, Just Zero, True) + aList = [Zero, Succ Zero, Succ (Succ Zero)] + type Pr = Pair (Succ Zero) '[Zero] + type Complex = Pair (Pair (Just Zero) Zero) False + type Tuple = '(False, Just Zero, True) + type AList = '[Zero, Succ Zero, Succ (Succ Zero)] + data instance Sing (z :: Pair a b) + = forall (n :: a) (n :: b). z ~ Pair n n => SPair (Sing n) (Sing n) + type SPair (z :: Pair a b) = Sing z + instance (SingKind (KProxy :: KProxy a), + SingKind (KProxy :: KProxy b)) => + SingKind (KProxy :: KProxy (Pair a b)) where + type instance DemoteRep (KProxy :: KProxy (Pair a b)) = + Pair (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) + fromSing (SPair b b) = Pair (fromSing b) (fromSing b) + toSing (Pair b b) + = case + (toSing b :: SomeSing (KProxy :: KProxy a), + toSing b :: SomeSing (KProxy :: KProxy b)) + of { + (SomeSing c, SomeSing c) -> SomeSing (SPair c c) } + instance (SingI n, SingI n) => SingI (Pair (n :: a) (n :: b)) where + sing = SPair sing sing + sPr = SPair (SSucc SZero) (SCons SZero SNil) + sComplex = SPair (SPair (SJust SZero) SZero) SFalse + sTuple = STuple3 SFalse (SJust SZero) STrue + sAList + = SCons + SZero (SCons (SSucc SZero) (SCons (SSucc (SSucc SZero)) SNil)) diff --git a/tests/compile-and-dump/Singletons/DataValues.ghc78.template b/tests/compile-and-dump/Singletons/DataValues.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/DataValues.ghc78.template @@ -0,0 +1,45 @@ +Singletons/DataValues.hs:0:0: Splicing declarations + singletons + [d| pr = Pair (Succ Zero) ([Zero]) + complex = Pair (Pair (Just Zero) Zero) False + tuple = (False, Just Zero, True) + aList = [Zero, Succ Zero, Succ (Succ Zero)] + + data Pair a b + = Pair a b + deriving (Show) |] + ======> + Singletons/DataValues.hs:(0,0)-(0,0) + data Pair a b + = Pair a b + deriving (Show) + pr = Pair (Succ Zero) [Zero] + complex = Pair (Pair (Just Zero) Zero) False + tuple = (False, Just Zero, True) + aList = [Zero, Succ Zero, Succ (Succ Zero)] + type Pr = Pair (Succ Zero) '[Zero] + type Complex = Pair (Pair (Just Zero) Zero) False + type Tuple = '(False, Just Zero, True) + type AList = '[Zero, Succ Zero, Succ (Succ Zero)] + data instance Sing (z :: Pair a b) + = forall (n :: a) (n :: b). z ~ Pair n n => SPair (Sing n) (Sing n) + type SPair (z :: Pair a b) = Sing z + instance (SingKind (KProxy :: KProxy a), + SingKind (KProxy :: KProxy b)) => + SingKind (KProxy :: KProxy (Pair a b)) where + type DemoteRep (KProxy :: KProxy (Pair a b)) = Pair (DemoteRep (KProxy :: KProxy a)) (DemoteRep (KProxy :: KProxy b)) + fromSing (SPair b b) = Pair (fromSing b) (fromSing b) + toSing (Pair b b) + = case + (toSing b :: SomeSing (KProxy :: KProxy a), + toSing b :: SomeSing (KProxy :: KProxy b)) + of { + (SomeSing c, SomeSing c) -> SomeSing (SPair c c) } + instance (SingI n, SingI n) => SingI (Pair (n :: a) (n :: b)) where + sing = SPair sing sing + sPr = SPair (SSucc SZero) (SCons SZero SNil) + sComplex = SPair (SPair (SJust SZero) SZero) SFalse + sTuple = STuple3 SFalse (SJust SZero) STrue + sAList + = SCons + SZero (SCons (SSucc SZero) (SCons (SSucc (SSucc SZero)) SNil)) diff --git a/tests/compile-and-dump/Singletons/DataValues.hs b/tests/compile-and-dump/Singletons/DataValues.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/DataValues.hs @@ -0,0 +1,18 @@ +module Singletons.DataValues where + +import Data.Singletons.TH +import Data.Singletons.Prelude +import Singletons.Nat + +$(singletons [d| + data Pair a b = Pair a b deriving Show + + pr = Pair (Succ Zero) ([Zero]) + + complex = Pair (Pair (Just Zero) Zero) False + + tuple = (False, Just Zero, True) + + aList = [Zero, Succ Zero, Succ (Succ Zero)] + + |]) diff --git a/tests/compile-and-dump/Singletons/Empty.ghc76.template b/tests/compile-and-dump/Singletons/Empty.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Empty.ghc76.template @@ -0,0 +1,15 @@ +Singletons/Empty.hs:0:0: Splicing declarations + singletons [d| data Empty |] + ======> + Singletons/Empty.hs:(0,0)-(0,0) + data Empty + data instance Sing (z :: Empty) + type SEmpty (z :: Empty) = Sing z + instance SingKind (KProxy :: KProxy Empty) where + type instance DemoteRep (KProxy :: KProxy Empty) = Empty + fromSing z + = case z of { + _ -> error "Empty case reached -- this should be impossible" } + toSing z + = case z of { + _ -> error "Empty case reached -- this should be impossible" } diff --git a/tests/compile-and-dump/Singletons/Empty.ghc78.template b/tests/compile-and-dump/Singletons/Empty.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Empty.ghc78.template @@ -0,0 +1,15 @@ +Singletons/Empty.hs:0:0: Splicing declarations + singletons [d| data Empty |] + ======> + Singletons/Empty.hs:(0,0)-(0,0) + data Empty + data instance Sing (z :: Empty) + type SEmpty (z :: Empty) = Sing z + instance SingKind (KProxy :: KProxy Empty) where + type DemoteRep (KProxy :: KProxy Empty) = Empty + fromSing z + = case z of { + _ -> error "Empty case reached -- this should be impossible" } + toSing z + = case z of { + _ -> error "Empty case reached -- this should be impossible" } diff --git a/tests/compile-and-dump/Singletons/Empty.hs b/tests/compile-and-dump/Singletons/Empty.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Empty.hs @@ -0,0 +1,7 @@ +module Singletons.Empty where + +import Data.Singletons.TH + +$(singletons [d| + data Empty + |]) diff --git a/tests/compile-and-dump/Singletons/EqInstances.ghc76.template b/tests/compile-and-dump/Singletons/EqInstances.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/EqInstances.ghc76.template @@ -0,0 +1,17 @@ +Singletons/EqInstances.hs:0:0: Splicing declarations + singEqInstances [''Foo, ''Empty] + ======> + Singletons/EqInstances.hs:0:0: + instance SEq (KProxy :: KProxy Foo) where + %:== SFLeaf SFLeaf = STrue + %:== SFLeaf (:%+: _ _) = SFalse + %:== (:%+: _ _) SFLeaf = SFalse + %:== (:%+: a a) (:%+: b b) = (%:&&) ((%:==) a b) ((%:==) a b) + type instance (:==) FLeaf FLeaf = True + type instance (:==) FLeaf (:+: b b) = False + type instance (:==) (:+: a a) FLeaf = False + type instance (:==) (:+: a a) (:+: b b) = :&& (:== a b) (:== a b) + instance SEq (KProxy :: KProxy Empty) where + %:== a _ + = case a of { + _ -> error "Empty case reached -- this should be impossible" } diff --git a/tests/compile-and-dump/Singletons/EqInstances.ghc78.template b/tests/compile-and-dump/Singletons/EqInstances.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/EqInstances.ghc78.template @@ -0,0 +1,22 @@ +Singletons/EqInstances.hs:0:0: Splicing declarations + singEqInstances [''Foo, ''Empty] + ======> + Singletons/EqInstances.hs:0:0: + instance SEq (KProxy :: KProxy Foo) where + (%:==) SFLeaf SFLeaf = STrue + (%:==) SFLeaf ((:%+:) _ _) = SFalse + (%:==) ((:%+:) _ _) SFLeaf = SFalse + (%:==) ((:%+:) a a) ((:%+:) b b) = (%:&&) ((%:==) a b) ((%:==) a b) + type family Equals_0123456789 (a :: Foo) (b :: Foo) :: Bool where + Equals_0123456789 FLeaf FLeaf = True + Equals_0123456789 ((:+:) a a) ((:+:) b b) = (:&&) ((==) a b) ((==) a b) + Equals_0123456789 (a :: Foo) (b :: Foo) = False + type instance (==) (a :: Foo) (b :: Foo) = Equals_0123456789 a b + instance SEq (KProxy :: KProxy Empty) where + (%:==) a _ + = case a of { + _ -> error "Empty case reached -- this should be impossible" } + type family Equals_0123456789 (a :: Empty) + (b :: Empty) :: Bool where + Equals_0123456789 (a :: Empty) (b :: Empty) = False + type instance (==) (a :: Empty) (b :: Empty) = Equals_0123456789 a b diff --git a/tests/compile-and-dump/Singletons/EqInstances.hs b/tests/compile-and-dump/Singletons/EqInstances.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/EqInstances.hs @@ -0,0 +1,8 @@ +module Singletons.EqInstances where + +import Data.Singletons.TH +import Data.Singletons.Bool +import Singletons.Empty +import Singletons.Operators + +$(singEqInstances [''Foo, ''Empty]) diff --git a/tests/compile-and-dump/Singletons/HigherOrder.ghc76.template b/tests/compile-and-dump/Singletons/HigherOrder.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/HigherOrder.ghc76.template @@ -0,0 +1,33 @@ +Singletons/HigherOrder.hs:0:0: Splicing declarations + singletons + [d| map :: (a -> b) -> [a] -> [b] + map _ [] = [] + map f (h : t) = (f h) : (map f t) + liftMaybe :: (a -> b) -> Maybe a -> Maybe b + liftMaybe f (Just x) = Just (f x) + liftMaybe _ Nothing = Nothing |] + ======> + Singletons/HigherOrder.hs:(0,0)-(0,0) + map :: forall a b. (a -> b) -> [a] -> [b] + map _ GHC.Types.[] = GHC.Types.[] + map f (h GHC.Types.: t) = ((f h) GHC.Types.: (map f t)) + liftMaybe :: forall a b. (a -> b) -> Maybe a -> Maybe b + liftMaybe f (Just x) = Just (f x) + liftMaybe _ Nothing = Nothing + type instance Map z GHC.Types.[] = GHC.Types.[] + type instance Map f (GHC.Types.: h t) = GHC.Types.: (f h) (Map f t) + type instance LiftMaybe f (Just x) = Just (f x) + type instance LiftMaybe z Nothing = Nothing + type family Map (a :: a -> b) (a :: [a]) :: [b] + type family LiftMaybe (a :: a -> b) (a :: Maybe a) :: Maybe b + sMap :: + forall (t :: a -> b) (t :: [a]). + (forall (t :: a). Sing t -> Sing (t t)) -> Sing t -> Sing (Map t t) + sMap _ SNil = SNil + sMap f (SCons h t) = SCons (f h) (sMap f t) + sLiftMaybe :: + forall (t :: a -> b) (t :: Maybe a). + (forall (t :: a). Sing t -> Sing (t t)) + -> Sing t -> Sing (LiftMaybe t t) + sLiftMaybe f (SJust x) = SJust (f x) + sLiftMaybe _ SNothing = SNothing diff --git a/tests/compile-and-dump/Singletons/HigherOrder.ghc78.template b/tests/compile-and-dump/Singletons/HigherOrder.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/HigherOrder.ghc78.template @@ -0,0 +1,33 @@ +Singletons/HigherOrder.hs:0:0: Splicing declarations + singletons + [d| map :: (a -> b) -> [a] -> [b] + map _ [] = [] + map f (h : t) = (f h) : (map f t) + liftMaybe :: (a -> b) -> Maybe a -> Maybe b + liftMaybe f (Just x) = Just (f x) + liftMaybe _ Nothing = Nothing |] + ======> + Singletons/HigherOrder.hs:(0,0)-(0,0) + map :: forall a b. (a -> b) -> [a] -> [b] + map _ GHC.Types.[] = [] + map f (h GHC.Types.: t) = ((f h) GHC.Types.: (map f t)) + liftMaybe :: forall a b. (a -> b) -> Maybe a -> Maybe b + liftMaybe f (Just x) = Just (f x) + liftMaybe _ Nothing = Nothing + type family Map (a :: a -> b) (a :: [a]) :: [b] where + Map z GHC.Types.[] = '[] + Map f ((GHC.Types.:) h t) = (GHC.Types.:) (f h) (Map f t) + type family LiftMaybe (a :: a -> b) (a :: Maybe a) :: Maybe b where + LiftMaybe f (Just x) = Just (f x) + LiftMaybe z Nothing = Nothing + sMap :: + forall (t :: a -> b) (t :: [a]). + (forall (t :: a). Sing t -> Sing (t t)) -> Sing t -> Sing (Map t t) + sMap _ SNil = SNil + sMap f (SCons h t) = SCons (f h) (sMap f t) + sLiftMaybe :: + forall (t :: a -> b) (t :: Maybe a). + (forall (t :: a). Sing t -> Sing (t t)) + -> Sing t -> Sing (LiftMaybe t t) + sLiftMaybe f (SJust x) = SJust (f x) + sLiftMaybe _ SNothing = SNothing diff --git a/tests/compile-and-dump/Singletons/HigherOrder.hs b/tests/compile-and-dump/Singletons/HigherOrder.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/HigherOrder.hs @@ -0,0 +1,15 @@ +module Singletons.HigherOrder where + +import Data.Singletons.TH +import Data.Singletons.List +import Data.Singletons.Maybe + +$(singletons [d| + map :: (a -> b) -> [a] -> [b] + map _ [] = [] + map f (h:t) = (f h) : (map f t) + + liftMaybe :: (a -> b) -> Maybe a -> Maybe b + liftMaybe f (Just x) = Just (f x) + liftMaybe _ Nothing = Nothing + |]) diff --git a/tests/compile-and-dump/Singletons/Maybe.ghc76.template b/tests/compile-and-dump/Singletons/Maybe.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Maybe.ghc76.template @@ -0,0 +1,53 @@ +Singletons/Maybe.hs:0:0: Splicing declarations + singletons + [d| data Maybe a + = Nothing | Just a + deriving (Eq, Show) |] + ======> + Singletons/Maybe.hs:(0,0)-(0,0) + data Maybe a + = Nothing | Just a + deriving (Eq, Show) + type instance (:==) Nothing Nothing = True + type instance (:==) Nothing (Just b) = False + type instance (:==) (Just a) Nothing = False + type instance (:==) (Just a) (Just b) = :== a b + data instance Sing (z :: Maybe a) + = z ~ Nothing => SNothing | + forall (n :: a). z ~ Just n => SJust (Sing n) + type SMaybe (z :: Maybe a) = Sing z + instance SingKind (KProxy :: KProxy a) => + SingKind (KProxy :: KProxy (Maybe a)) where + type instance DemoteRep (KProxy :: KProxy (Maybe a)) = + Maybe (DemoteRep (KProxy :: KProxy a)) + fromSing SNothing = Nothing + fromSing (SJust b) = Just (fromSing b) + toSing Nothing = SomeSing SNothing + toSing (Just b) + = case toSing b :: SomeSing (KProxy :: KProxy a) of { + SomeSing c -> SomeSing (SJust c) } + instance SEq (KProxy :: KProxy a) => + SEq (KProxy :: KProxy (Maybe a)) where + %:== SNothing SNothing = STrue + %:== SNothing (SJust _) = SFalse + %:== (SJust _) SNothing = SFalse + %:== (SJust a) (SJust b) = (%:==) a b + instance SDecide (KProxy :: KProxy a) => + SDecide (KProxy :: KProxy (Maybe a)) where + %~ SNothing SNothing = Proved Refl + %~ SNothing (SJust _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SJust _) SNothing + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SJust a) (SJust b) + = case (%~) a b of { + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\ Refl -> contra Refl) } + instance SingI Nothing where + sing = SNothing + instance SingI n => SingI (Just (n :: a)) where + sing = SJust sing diff --git a/tests/compile-and-dump/Singletons/Maybe.ghc78.template b/tests/compile-and-dump/Singletons/Maybe.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Maybe.ghc78.template @@ -0,0 +1,54 @@ +Singletons/Maybe.hs:0:0: Splicing declarations + singletons + [d| data Maybe a + = Nothing | Just a + deriving (Eq, Show) |] + ======> + Singletons/Maybe.hs:(0,0)-(0,0) + data Maybe a + = Nothing | Just a + deriving (Eq, Show) + type family Equals_0123456789 (a :: Maybe k) + (b :: Maybe k) :: Bool where + Equals_0123456789 Nothing Nothing = True + Equals_0123456789 (Just a) (Just b) = (==) a b + Equals_0123456789 (a :: Maybe k) (b :: Maybe k) = False + type instance (==) (a :: Maybe k) (b :: Maybe k) = Equals_0123456789 a b + data instance Sing (z :: Maybe a) + = z ~ Nothing => SNothing | + forall (n :: a). z ~ Just n => SJust (Sing n) + type SMaybe (z :: Maybe a) = Sing z + instance SingKind (KProxy :: KProxy a) => + SingKind (KProxy :: KProxy (Maybe a)) where + type DemoteRep (KProxy :: KProxy (Maybe a)) = Maybe (DemoteRep (KProxy :: KProxy a)) + fromSing SNothing = Nothing + fromSing (SJust b) = Just (fromSing b) + toSing Nothing = SomeSing SNothing + toSing (Just b) + = case toSing b :: SomeSing (KProxy :: KProxy a) of { + SomeSing c -> SomeSing (SJust c) } + instance SEq (KProxy :: KProxy a) => + SEq (KProxy :: KProxy (Maybe a)) where + (%:==) SNothing SNothing = STrue + (%:==) SNothing (SJust _) = SFalse + (%:==) (SJust _) SNothing = SFalse + (%:==) (SJust a) (SJust b) = (%:==) a b + instance SDecide (KProxy :: KProxy a) => + SDecide (KProxy :: KProxy (Maybe a)) where + (%~) SNothing SNothing = Proved Refl + (%~) SNothing (SJust _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SJust _) SNothing + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SJust a) (SJust b) + = case (%~) a b of { + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\ Refl -> contra Refl) } + instance SingI Nothing where + sing = SNothing + instance SingI n => SingI (Just (n :: a)) where + sing = SJust sing diff --git a/tests/compile-and-dump/Singletons/Maybe.hs b/tests/compile-and-dump/Singletons/Maybe.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Maybe.hs @@ -0,0 +1,7 @@ +module Singletons.Maybe where + +import Data.Singletons.TH + +$(singletons [d| + data Maybe a = Nothing | Just a deriving (Eq, Show) + |]) diff --git a/tests/compile-and-dump/Singletons/Nat.ghc76.template b/tests/compile-and-dump/Singletons/Nat.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Nat.ghc76.template @@ -0,0 +1,79 @@ +Singletons/Nat.hs:0:0: Splicing declarations + singletons + + [d| plus :: Nat -> Nat -> Nat + plus Zero m = m + plus (Succ n) m = Succ (plus n m) + + pred :: Nat -> Nat + pred Zero = Zero + pred (Succ n) = n + + data Nat + where + Zero :: Nat + Succ :: Nat -> Nat + deriving (Eq, Show, Read) |] + ======> + Singletons/Nat.hs:(0,0)-(0,0) + data Nat + = Zero | Succ Nat + deriving (Eq, Show, Read) + plus :: Nat -> Nat -> Nat + plus Zero m = m + plus (Succ n) m = Succ (plus n m) + pred :: Nat -> Nat + pred Zero = Zero + pred (Succ n) = n + type instance (:==) Zero Zero = True + type instance (:==) Zero (Succ b) = False + type instance (:==) (Succ a) Zero = False + type instance (:==) (Succ a) (Succ b) = :== a b + type instance Plus Zero m = m + type instance Plus (Succ n) m = Succ (Plus n m) + type instance Pred Zero = Zero + type instance Pred (Succ n) = n + type family Plus (a :: Nat) (a :: Nat) :: Nat + type family Pred (a :: Nat) :: Nat + data instance Sing (z :: Nat) + = z ~ Zero => SZero | + forall (n :: Nat). z ~ Succ n => SSucc (Sing n) + type SNat (z :: Nat) = Sing z + instance SingKind (KProxy :: KProxy Nat) where + type instance DemoteRep (KProxy :: KProxy Nat) = Nat + fromSing SZero = Zero + fromSing (SSucc b) = Succ (fromSing b) + toSing Zero = SomeSing SZero + toSing (Succ b) + = case toSing b :: SomeSing (KProxy :: KProxy Nat) of { + SomeSing c -> SomeSing (SSucc c) } + instance SEq (KProxy :: KProxy Nat) where + %:== SZero SZero = STrue + %:== SZero (SSucc _) = SFalse + %:== (SSucc _) SZero = SFalse + %:== (SSucc a) (SSucc b) = (%:==) a b + instance SDecide (KProxy :: KProxy Nat) where + %~ SZero SZero = Proved Refl + %~ SZero (SSucc _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SSucc _) SZero + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SSucc a) (SSucc b) + = case (%~) a b of { + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\ Refl -> contra Refl) } + instance SingI Zero where + sing = SZero + instance SingI n => SingI (Succ (n :: Nat)) where + sing = SSucc sing + sPlus :: + forall (t :: Nat) (t :: Nat). Sing t -> Sing t -> Sing (Plus t t) + sPlus SZero m = m + sPlus (SSucc n) m = SSucc (sPlus n m) + sPred :: forall (t :: Nat). Sing t -> Sing (Pred t) + sPred SZero = SZero + sPred (SSucc n) = n diff --git a/tests/compile-and-dump/Singletons/Nat.ghc78.template b/tests/compile-and-dump/Singletons/Nat.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Nat.ghc78.template @@ -0,0 +1,80 @@ +Singletons/Nat.hs:0:0: Splicing declarations + singletons + + [d| plus :: Nat -> Nat -> Nat + plus Zero m = m + plus (Succ n) m = Succ (plus n m) + + pred :: Nat -> Nat + pred Zero = Zero + pred (Succ n) = n + + data Nat + where + Zero :: Nat + Succ :: Nat -> Nat + deriving (Eq, Show, Read) |] + ======> + Singletons/Nat.hs:(0,0)-(0,0) + data Nat + = Zero | Succ Nat + deriving (Eq, Show, Read) + plus :: Nat -> Nat -> Nat + plus Zero m = m + plus (Succ n) m = Succ (plus n m) + pred :: Nat -> Nat + pred Zero = Zero + pred (Succ n) = n + type family Equals_0123456789 (a :: Nat) (b :: Nat) :: Bool where + Equals_0123456789 Zero Zero = True + Equals_0123456789 (Succ a) (Succ b) = (==) a b + Equals_0123456789 (a :: Nat) (b :: Nat) = False + type instance (==) (a :: Nat) (b :: Nat) = Equals_0123456789 a b + type family Plus (a :: Nat) (a :: Nat) :: Nat where + Plus Zero m = m + Plus (Succ n) m = Succ (Plus n m) + type family Pred (a :: Nat) :: Nat where + Pred Zero = Zero + Pred (Succ n) = n + data instance Sing (z :: Nat) + = z ~ Zero => SZero | + forall (n :: Nat). z ~ Succ n => SSucc (Sing n) + type SNat (z :: Nat) = Sing z + instance SingKind (KProxy :: KProxy Nat) where + type DemoteRep (KProxy :: KProxy Nat) = Nat + fromSing SZero = Zero + fromSing (SSucc b) = Succ (fromSing b) + toSing Zero = SomeSing SZero + toSing (Succ b) + = case toSing b :: SomeSing (KProxy :: KProxy Nat) of { + SomeSing c -> SomeSing (SSucc c) } + instance SEq (KProxy :: KProxy Nat) where + (%:==) SZero SZero = STrue + (%:==) SZero (SSucc _) = SFalse + (%:==) (SSucc _) SZero = SFalse + (%:==) (SSucc a) (SSucc b) = (%:==) a b + instance SDecide (KProxy :: KProxy Nat) where + (%~) SZero SZero = Proved Refl + (%~) SZero (SSucc _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SSucc _) SZero + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SSucc a) (SSucc b) + = case (%~) a b of { + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\ Refl -> contra Refl) } + instance SingI Zero where + sing = SZero + instance SingI n => SingI (Succ (n :: Nat)) where + sing = SSucc sing + sPlus :: + forall (t :: Nat) (t :: Nat). Sing t -> Sing t -> Sing (Plus t t) + sPlus SZero m = m + sPlus (SSucc n) m = SSucc (sPlus n m) + sPred :: forall (t :: Nat). Sing t -> Sing (Pred t) + sPred SZero = SZero + sPred (SSucc n) = n diff --git a/tests/compile-and-dump/Singletons/Nat.hs b/tests/compile-and-dump/Singletons/Nat.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Nat.hs @@ -0,0 +1,18 @@ +module Singletons.Nat where + +import Data.Singletons.TH + +$(singletons [d| + data Nat where + Zero :: Nat + Succ :: Nat -> Nat + deriving (Eq, Show, Read) + + plus :: Nat -> Nat -> Nat + plus Zero m = m + plus (Succ n) m = Succ (plus n m) + + pred :: Nat -> Nat + pred Zero = Zero + pred (Succ n) = n + |]) diff --git a/tests/compile-and-dump/Singletons/Operators.ghc76.template b/tests/compile-and-dump/Singletons/Operators.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Operators.ghc76.template @@ -0,0 +1,56 @@ +Singletons/Operators.hs:0:0: Splicing declarations + singletons + [d| child :: Foo -> Foo + child FLeaf = FLeaf + child (a :+: _) = a + + :: Nat -> Nat -> Nat + Zero + m = m + (Succ n) + m = Succ (n + m) + + data Foo + where + FLeaf :: Foo + :+: :: Foo -> Foo -> Foo |] + ======> + Singletons/Operators.hs:(0,0)-(0,0) + data Foo = FLeaf | (:+:) Foo Foo + child :: Foo -> Foo + child FLeaf = FLeaf + child (a :+: _) = a + + :: Nat -> Nat -> Nat + + Zero m = m + + (Succ n) m = Succ (n + m) + type instance Child FLeaf = FLeaf + type instance Child (:+: a z) = a + type instance (:+) Zero m = m + type instance (:+) (Succ n) m = Succ (:+ n m) + type family Child (a :: Foo) :: Foo + type family (:+) (a :: Nat) (a :: Nat) :: Nat + data instance Sing (z :: Foo) + = z ~ FLeaf => SFLeaf | + forall (n :: Foo) (n :: Foo). z ~ :+: n n => + (:%+:) (Sing n) (Sing n) + type SFoo (z :: Foo) = Sing z + instance SingKind (KProxy :: KProxy Foo) where + type instance DemoteRep (KProxy :: KProxy Foo) = Foo + fromSing SFLeaf = FLeaf + fromSing (:%+: b b) = (:+:) (fromSing b) (fromSing b) + toSing FLeaf = SomeSing SFLeaf + toSing (:+: b b) + = case + (toSing b :: SomeSing (KProxy :: KProxy Foo), + toSing b :: SomeSing (KProxy :: KProxy Foo)) + of { + (SomeSing c, SomeSing c) -> SomeSing ((:%+:) c c) } + instance SingI FLeaf where + sing = SFLeaf + instance (SingI n, SingI n) => + SingI (:+: (n :: Foo) (n :: Foo)) where + sing = (:%+:) sing sing + sChild :: forall (t :: Foo). Sing t -> Sing (Child t) + sChild SFLeaf = SFLeaf + sChild (:%+: a _) = a + %:+ :: + forall (t :: Nat) (t :: Nat). Sing t -> Sing t -> Sing (:+ t t) + %:+ SZero m = m + %:+ (SSucc n) m = SSucc ((%:+) n m) diff --git a/tests/compile-and-dump/Singletons/Operators.ghc78.template b/tests/compile-and-dump/Singletons/Operators.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Operators.ghc78.template @@ -0,0 +1,56 @@ +Singletons/Operators.hs:0:0: Splicing declarations + singletons + [d| child :: Foo -> Foo + child FLeaf = FLeaf + child (a :+: _) = a + (+) :: Nat -> Nat -> Nat + Zero + m = m + (Succ n) + m = Succ (n + m) + + data Foo + where + FLeaf :: Foo + :+: :: Foo -> Foo -> Foo |] + ======> + Singletons/Operators.hs:(0,0)-(0,0) + data Foo = FLeaf | (:+:) Foo Foo + child :: Foo -> Foo + child FLeaf = FLeaf + child (a :+: _) = a + (+) :: Nat -> Nat -> Nat + (+) Zero m = m + (+) (Succ n) m = Succ (n + m) + type family Child (a :: Foo) :: Foo where + Child FLeaf = FLeaf + Child ((:+:) a z) = a + type family (:+) (a :: Nat) (a :: Nat) :: Nat where + (:+) Zero m = m + (:+) (Succ n) m = Succ ((:+) n m) + data instance Sing (z :: Foo) + = z ~ FLeaf => SFLeaf | + forall (n :: Foo) (n :: Foo). z ~ (:+:) n n => + (:%+:) (Sing n) (Sing n) + type SFoo (z :: Foo) = Sing z + instance SingKind (KProxy :: KProxy Foo) where + type DemoteRep (KProxy :: KProxy Foo) = Foo + fromSing SFLeaf = FLeaf + fromSing ((:%+:) b b) = (:+:) (fromSing b) (fromSing b) + toSing FLeaf = SomeSing SFLeaf + toSing ((:+:) b b) + = case + (toSing b :: SomeSing (KProxy :: KProxy Foo), + toSing b :: SomeSing (KProxy :: KProxy Foo)) + of { + (SomeSing c, SomeSing c) -> SomeSing ((:%+:) c c) } + instance SingI FLeaf where + sing = SFLeaf + instance (SingI n, SingI n) => + SingI ((:+:) (n :: Foo) (n :: Foo)) where + sing = (:%+:) sing sing + sChild :: forall (t :: Foo). Sing t -> Sing (Child t) + sChild SFLeaf = SFLeaf + sChild ((:%+:) a _) = a + (%:+) :: + forall (t :: Nat) (t :: Nat). Sing t -> Sing t -> Sing ((:+) t t) + (%:+) SZero m = m + (%:+) (SSucc n) m = SSucc ((%:+) n m) diff --git a/tests/compile-and-dump/Singletons/Operators.hs b/tests/compile-and-dump/Singletons/Operators.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Operators.hs @@ -0,0 +1,18 @@ +module Singletons.Operators where + +import Data.Singletons.TH +import Singletons.Nat + +$(singletons [d| + data Foo where + FLeaf :: Foo + (:+:) :: Foo -> Foo -> Foo + + child :: Foo -> Foo + child FLeaf = FLeaf + child (a :+: _) = a + + (+) :: Nat -> Nat -> Nat + Zero + m = m + (Succ n) + m = Succ (n + m) + |]) diff --git a/tests/compile-and-dump/Singletons/Star.ghc76.template b/tests/compile-and-dump/Singletons/Star.ghc76.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Star.ghc76.template @@ -0,0 +1,188 @@ +Singletons/Star.hs:0:0: Splicing declarations + singletonStar [''Nat, ''Int, ''String, ''Maybe, ''Vec] + ======> + Singletons/Star.hs:0:0: + data Rep + = Nat | Int | String | Maybe Rep | Vec Rep Nat + deriving (Eq, Show, Read) + type instance (:==) Nat Nat = True + type instance (:==) Nat Int = False + type instance (:==) Nat String = False + type instance (:==) Nat (Maybe b) = False + type instance (:==) Nat (Vec b b) = False + type instance (:==) Int Nat = False + type instance (:==) Int Int = True + type instance (:==) Int String = False + type instance (:==) Int (Maybe b) = False + type instance (:==) Int (Vec b b) = False + type instance (:==) String Nat = False + type instance (:==) String Int = False + type instance (:==) String String = True + type instance (:==) String (Maybe b) = False + type instance (:==) String (Vec b b) = False + type instance (:==) (Maybe a) Nat = False + type instance (:==) (Maybe a) Int = False + type instance (:==) (Maybe a) String = False + type instance (:==) (Maybe a) (Maybe b) = :== a b + type instance (:==) (Maybe a) (Vec b b) = False + type instance (:==) (Vec a a) Nat = False + type instance (:==) (Vec a a) Int = False + type instance (:==) (Vec a a) String = False + type instance (:==) (Vec a a) (Maybe b) = False + type instance (:==) (Vec a a) (Vec b b) = :&& (:== a b) (:== a b) + data instance Sing (z :: *) + = z ~ Nat => SNat | + z ~ Int => SInt | + z ~ String => SString | + forall (n :: *). z ~ Maybe n => SMaybe (Sing n) | + forall (n :: *) (n :: Nat). z ~ Vec n n => SVec (Sing n) (Sing n) + type SRep (z :: *) = Sing z + instance SingKind (KProxy :: KProxy *) where + type instance DemoteRep (KProxy :: KProxy *) = Rep + fromSing SNat = Nat + fromSing SInt = Int + fromSing SString = String + fromSing (SMaybe b) = Maybe (fromSing b) + fromSing (SVec b b) = Vec (fromSing b) (fromSing b) + toSing Nat = SomeSing SNat + toSing Int = SomeSing SInt + toSing String = SomeSing SString + toSing (Maybe b) + = case toSing b :: SomeSing (KProxy :: KProxy *) of { + SomeSing c -> SomeSing (SMaybe c) } + toSing (Vec b b) + = case + (toSing b :: SomeSing (KProxy :: KProxy *), + toSing b :: SomeSing (KProxy :: KProxy Nat)) + of { + (SomeSing c, SomeSing c) -> SomeSing (SVec c c) } + instance SEq (KProxy :: KProxy *) where + %:== SNat SNat = STrue + %:== SNat SInt = SFalse + %:== SNat SString = SFalse + %:== SNat (SMaybe _) = SFalse + %:== SNat (SVec _ _) = SFalse + %:== SInt SNat = SFalse + %:== SInt SInt = STrue + %:== SInt SString = SFalse + %:== SInt (SMaybe _) = SFalse + %:== SInt (SVec _ _) = SFalse + %:== SString SNat = SFalse + %:== SString SInt = SFalse + %:== SString SString = STrue + %:== SString (SMaybe _) = SFalse + %:== SString (SVec _ _) = SFalse + %:== (SMaybe _) SNat = SFalse + %:== (SMaybe _) SInt = SFalse + %:== (SMaybe _) SString = SFalse + %:== (SMaybe a) (SMaybe b) = (%:==) a b + %:== (SMaybe _) (SVec _ _) = SFalse + %:== (SVec _ _) SNat = SFalse + %:== (SVec _ _) SInt = SFalse + %:== (SVec _ _) SString = SFalse + %:== (SVec _ _) (SMaybe _) = SFalse + %:== (SVec a a) (SVec b b) = (%:&&) ((%:==) a b) ((%:==) a b) + instance SDecide (KProxy :: KProxy *) where + %~ SNat SNat = Proved Refl + %~ SNat SInt + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SNat SString + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SNat (SMaybe _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SNat (SVec _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SInt SNat + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SInt SInt = Proved Refl + %~ SInt SString + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SInt (SMaybe _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SInt (SVec _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SString SNat + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SString SInt + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SString SString = Proved Refl + %~ SString (SMaybe _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ SString (SVec _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SMaybe _) SNat + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SMaybe _) SInt + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SMaybe _) SString + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SMaybe a) (SMaybe b) + = case (%~) a b of { + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\ Refl -> contra Refl) } + %~ (SMaybe _) (SVec _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SVec _ _) SNat + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SVec _ _) SInt + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SVec _ _) SString + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SVec _ _) (SMaybe _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + %~ (SVec a a) (SVec b b) + = case ((%~) a b, (%~) a b) of { + (Proved Refl, Proved Refl) -> Proved Refl + (Disproved contra, _) -> Disproved (\ Refl -> contra Refl) + (_, Disproved contra) -> Disproved (\ Refl -> contra Refl) } + instance SingI Nat where + sing = SNat + instance SingI Int where + sing = SInt + instance SingI String where + sing = SString + instance SingI n => SingI (Maybe (n :: *)) where + sing = SMaybe sing + instance (SingI n, SingI n) => + SingI (Vec (n :: *) (n :: Nat)) where + sing = SVec sing sing diff --git a/tests/compile-and-dump/Singletons/Star.ghc78.template b/tests/compile-and-dump/Singletons/Star.ghc78.template new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Star.ghc78.template @@ -0,0 +1,142 @@ +Singletons/Star.hs:0:0: Splicing declarations + singletonStar [''Nat, ''Int, ''String, ''Maybe, ''Vec] + ======> + Singletons/Star.hs:0:0: + data Rep + = Nat | Int | String | Maybe Rep | Vec Rep Nat + deriving (Eq, Show, Read) + instance SDecide (KProxy :: KProxy *) where + (%~) SNat SNat = Proved Refl + (%~) SNat SInt + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SNat SString + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SNat (SMaybe _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SNat (SVec _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SInt SNat + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SInt SInt = Proved Refl + (%~) SInt SString + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SInt (SMaybe _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SInt (SVec _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SString SNat + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SString SInt + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SString SString = Proved Refl + (%~) SString (SMaybe _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) SString (SVec _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SMaybe _) SNat + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SMaybe _) SInt + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SMaybe _) SString + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SMaybe a) (SMaybe b) + = case (%~) a b of { + Proved Refl -> Proved Refl + Disproved contra -> Disproved (\ Refl -> contra Refl) } + (%~) (SMaybe _) (SVec _ _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SVec _ _) SNat + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SVec _ _) SInt + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SVec _ _) SString + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SVec _ _) (SMaybe _) + = Disproved + (\case { + _ -> error "Empty case reached -- this should be impossible" }) + (%~) (SVec a a) (SVec b b) + = case ((%~) a b, (%~) a b) of { + (Proved Refl, Proved Refl) -> Proved Refl + (Disproved contra, _) -> Disproved (\ Refl -> contra Refl) + (_, Disproved contra) -> Disproved (\ Refl -> contra Refl) } + instance SEq (KProxy :: KProxy *) where + (%:==) a b + = case (%~) a b of { + Proved Refl -> STrue + Disproved _ -> Unsafe.Coerce.unsafeCoerce SFalse } + data instance Sing (z :: *) + = z ~ Nat => SNat | + z ~ Int => SInt | + z ~ String => SString | + forall (n :: *). z ~ Maybe n => SMaybe (Sing n) | + forall (n :: *) (n :: Nat). z ~ Vec n n => SVec (Sing n) (Sing n) + type SRep (z :: *) = Sing z + instance SingKind (KProxy :: KProxy *) where + type DemoteRep (KProxy :: KProxy *) = Rep + fromSing SNat = Nat + fromSing SInt = Int + fromSing SString = String + fromSing (SMaybe b) = Maybe (fromSing b) + fromSing (SVec b b) = Vec (fromSing b) (fromSing b) + toSing Nat = SomeSing SNat + toSing Int = SomeSing SInt + toSing String = SomeSing SString + toSing (Maybe b) + = case toSing b :: SomeSing (KProxy :: KProxy *) of { + SomeSing c -> SomeSing (SMaybe c) } + toSing (Vec b b) + = case + (toSing b :: SomeSing (KProxy :: KProxy *), + toSing b :: SomeSing (KProxy :: KProxy Nat)) + of { + (SomeSing c, SomeSing c) -> SomeSing (SVec c c) } + instance SingI Nat where + sing = SNat + instance SingI Int where + sing = SInt + instance SingI String where + sing = SString + instance SingI n => SingI (Maybe (n :: *)) where + sing = SMaybe sing + instance (SingI n, SingI n) => + SingI (Vec (n :: *) (n :: Nat)) where + sing = SVec sing sing diff --git a/tests/compile-and-dump/Singletons/Star.hs b/tests/compile-and-dump/Singletons/Star.hs new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/Singletons/Star.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +module Singletons.Star where + +import Data.Singletons.Prelude +import Data.Singletons.Decide +import Data.Singletons.CustomStar +import Singletons.Nat + +data Vec :: * -> Nat -> * where + VNil :: Vec a Zero + VCons :: a -> Vec a n -> Vec a (Succ n) + +$(singletonStar [''Nat, ''Int, ''String, ''Maybe, ''Vec]) diff --git a/tests/compile-and-dump/buildGoldenFiles.awk b/tests/compile-and-dump/buildGoldenFiles.awk new file mode 100644 --- /dev/null +++ b/tests/compile-and-dump/buildGoldenFiles.awk @@ -0,0 +1,1 @@ +/INSERT/{while((getline line < $2) > 0 ){if(line !~ /INSERT/){print line}}close($2);next}1