packages feed

singletons 0.9.3 → 0.10.0

raw patch · 94 files changed

+14421/−3182 lines, 94 filesdep +Cabaldep +constraintsdep +filepathdep −sybdep ~base

Dependencies added: Cabal, constraints, filepath, process, tasty, tasty-golden

Dependencies removed: syb

Dependency ranges changed: base

Files

CHANGES.md view
@@ -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 -----
− Data/Singletons.hs 
@@ -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--- <http://www.cis.upenn.edu/~eir/packages/singletons/README.html> and the--- original paper presenting this library, available at--- <http://www.cis.upenn.edu/~eir/papers/2012/singletons/paper.pdf>.----------------------------------------------------------------------------------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 <https://ghc.haskell.org/trac/ghc/ticket/3927>.--- 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)
− Data/Singletons/Bool.hs 
@@ -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-  |])-
− Data/Singletons/Core.hs 
@@ -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-
− Data/Singletons/CustomStar.hs 
@@ -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
− Data/Singletons/Decide.hs 
@@ -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
− Data/Singletons/Either.hs 
@@ -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-  |])
− Data/Singletons/Eq.hs 
@@ -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
− Data/Singletons/List.hs 
@@ -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-  |])--
− Data/Singletons/Maybe.hs 
@@ -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)-  |])
− Data/Singletons/Prelude.hs 
@@ -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
− Data/Singletons/Promote.hs 
@@ -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 <<Rep>> 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 <<where>> 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 <<where>> 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)
− Data/Singletons/Singletons.hs 
@@ -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 <http://www.cis.upenn.edu/~eir/packages/singletons/README.html> 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 <<where>> 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 <<where>> 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))
− Data/Singletons/TH.hs 
@@ -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 <<cases>> 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))
− Data/Singletons/Tuple.hs 
@@ -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)-  |])
− Data/Singletons/TypeRepStar.hs 
@@ -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
− Data/Singletons/Types.hs 
@@ -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
− Data/Singletons/Util.hs 
@@ -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
− Data/Singletons/Void.hs 
@@ -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
README.md view
@@ -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 --------------------------------
singletons.cabal view
@@ -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 <eir@cis.upenn.edu> 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 @@     (<http://www.cis.upenn.edu/~eir/papers/2012/singletons/paper.pdf>)      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
+ src/Data/Singletons.hs view
@@ -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+-- <http://www.cis.upenn.edu/~eir/packages/singletons/README.html> and the+-- original paper presenting this library, available at+-- <http://www.cis.upenn.edu/~eir/papers/2012/singletons/paper.pdf>.+--+----------------------------------------------------------------------------++#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 <https://ghc.haskell.org/trac/ghc/ticket/3927>.+-- 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"+
+ src/Data/Singletons/Bool.hs view
@@ -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+  |])
+ src/Data/Singletons/CustomStar.hs view
@@ -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
+ src/Data/Singletons/Decide.hs view
@@ -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
+ src/Data/Singletons/Either.hs view
@@ -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+  |])
+ src/Data/Singletons/Eq.hs view
@@ -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)
+ src/Data/Singletons/Instances.hs view
@@ -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)+
+ src/Data/Singletons/List.hs view
@@ -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+  |])
+ src/Data/Singletons/Maybe.hs view
@@ -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)+  |])
+ src/Data/Singletons/Prelude.hs view
@@ -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
+ src/Data/Singletons/Promote.hs view
@@ -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 <<Rep>> 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 <<where>> 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 <<where>> 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)
+ src/Data/Singletons/Singletons.hs view
@@ -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 <http://www.cis.upenn.edu/~eir/packages/singletons/README.html> 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 <<where>> 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 <<where>> 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))
+ src/Data/Singletons/TH.hs view
@@ -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 <<cases>> 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))
+ src/Data/Singletons/Tuple.hs view
@@ -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)+  |])
+ src/Data/Singletons/TypeLits.hs view
@@ -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)
+ src/Data/Singletons/TypeRepStar.hs view
@@ -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
+ src/Data/Singletons/Types.hs view
@@ -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
+ src/Data/Singletons/Util.hs view
@@ -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
+ src/Data/Singletons/Void.hs view
@@ -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
+ tests/SingletonsTestSuite.hs view
@@ -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"+    ]+  ]+
+ tests/SingletonsTestSuiteUtils.hs view
@@ -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)
+ tests/compile-and-dump/GradingClient/Database.ghc76.template view
@@ -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 }
+ tests/compile-and-dump/GradingClient/Database.ghc78.template view
@@ -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 }
+ tests/compile-and-dump/GradingClient/Database.hs view
@@ -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 <<inProof>>+        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
+ tests/compile-and-dump/GradingClient/Main.ghc76.template view
@@ -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))
+ tests/compile-and-dump/GradingClient/Main.ghc78.template view
@@ -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))
+ tests/compile-and-dump/GradingClient/Main.hs view
@@ -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"
+ tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc76.template view
@@ -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)
+ tests/compile-and-dump/InsertionSort/InsertionSortImp.ghc78.template view
@@ -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)
+ tests/compile-and-dump/InsertionSort/InsertionSortImp.hs view
@@ -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)
+ tests/compile-and-dump/Promote/NumArgs.ghc76.template view
@@ -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
+ tests/compile-and-dump/Promote/NumArgs.ghc78.template view
@@ -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
+ tests/compile-and-dump/Promote/NumArgs.hs view
@@ -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+  |])
+ tests/compile-and-dump/Promote/PatternMatching.ghc76.template view
@@ -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
+ tests/compile-and-dump/Promote/PatternMatching.ghc78.template view
@@ -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
+ tests/compile-and-dump/Promote/PatternMatching.hs view
@@ -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+  |])
+ tests/compile-and-dump/Singletons/AtPattern.ghc76.template view
@@ -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
+ tests/compile-and-dump/Singletons/AtPattern.ghc78.template view
@@ -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
+ tests/compile-and-dump/Singletons/AtPattern.hs view
@@ -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+ |])
+ tests/compile-and-dump/Singletons/BadPlus.ghc76.template view
@@ -0,0 +1,2 @@+Singletons/BadPlus.hs:0:0:+    No type signature for functions: "badPlus"; cannot promote or make singletons.
+ tests/compile-and-dump/Singletons/BadPlus.ghc78.template view
@@ -0,0 +1,2 @@+Singletons/BadPlus.hs:0:0:+    No type signature for functions: "badPlus"; cannot promote or make singletons.
+ tests/compile-and-dump/Singletons/BadPlus.hs view
@@ -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)+ |])
+ tests/compile-and-dump/Singletons/BoxUnBox.ghc76.template view
@@ -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
+ tests/compile-and-dump/Singletons/BoxUnBox.ghc78.template view
@@ -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
+ tests/compile-and-dump/Singletons/BoxUnBox.hs view
@@ -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+ |])
+ tests/compile-and-dump/Singletons/Contains.ghc76.template view
@@ -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)
+ tests/compile-and-dump/Singletons/Contains.ghc78.template view
@@ -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)
+ tests/compile-and-dump/Singletons/Contains.hs view
@@ -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)+ |])
+ tests/compile-and-dump/Singletons/DataValues.ghc76.template view
@@ -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))
+ tests/compile-and-dump/Singletons/DataValues.ghc78.template view
@@ -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))
+ tests/compile-and-dump/Singletons/DataValues.hs view
@@ -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)]++  |])
+ tests/compile-and-dump/Singletons/Empty.ghc76.template view
@@ -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" }
+ tests/compile-and-dump/Singletons/Empty.ghc78.template view
@@ -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" }
+ tests/compile-and-dump/Singletons/Empty.hs view
@@ -0,0 +1,7 @@+module Singletons.Empty where++import Data.Singletons.TH++$(singletons [d|+  data Empty+ |])
+ tests/compile-and-dump/Singletons/EqInstances.ghc76.template view
@@ -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" }
+ tests/compile-and-dump/Singletons/EqInstances.ghc78.template view
@@ -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
+ tests/compile-and-dump/Singletons/EqInstances.hs view
@@ -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])
+ tests/compile-and-dump/Singletons/HigherOrder.ghc76.template view
@@ -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
+ tests/compile-and-dump/Singletons/HigherOrder.ghc78.template view
@@ -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
+ tests/compile-and-dump/Singletons/HigherOrder.hs view
@@ -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+ |])
+ tests/compile-and-dump/Singletons/Maybe.ghc76.template view
@@ -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
+ tests/compile-and-dump/Singletons/Maybe.ghc78.template view
@@ -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
+ tests/compile-and-dump/Singletons/Maybe.hs view
@@ -0,0 +1,7 @@+module Singletons.Maybe where++import Data.Singletons.TH++$(singletons [d|+  data Maybe a = Nothing | Just a deriving (Eq, Show)+ |])
+ tests/compile-and-dump/Singletons/Nat.ghc76.template view
@@ -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
+ tests/compile-and-dump/Singletons/Nat.ghc78.template view
@@ -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
+ tests/compile-and-dump/Singletons/Nat.hs view
@@ -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+ |])
+ tests/compile-and-dump/Singletons/Operators.ghc76.template view
@@ -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)
+ tests/compile-and-dump/Singletons/Operators.ghc78.template view
@@ -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)
+ tests/compile-and-dump/Singletons/Operators.hs view
@@ -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)+ |])
+ tests/compile-and-dump/Singletons/Star.ghc76.template view
@@ -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
+ tests/compile-and-dump/Singletons/Star.ghc78.template view
@@ -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
+ tests/compile-and-dump/Singletons/Star.hs view
@@ -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])
+ tests/compile-and-dump/buildGoldenFiles.awk view
@@ -0,0 +1,1 @@+/INSERT/{while((getline line < $2) > 0 ){if(line !~ /INSERT/){print line}}close($2);next}1