diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for recover-rtti + +## 0.1.0.0 -- 2021-03-11 + +* Alpha release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2021, Juspay Technologies Pvt Ltd, Well-Typed LLP + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Juspay Technologies, nor Well-Typed LLP, + nor the names of other contributors may be used to endorse or promote + products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,33 @@ +# recover-rtti + +Recover run-time type information from the GHC heap. The key function in this +library is + +```haskell +classify :: a -> Classifier a +``` + +which recovers type information about values about which we know nothing (in +particular, no type class constraints). One example use case is the following +`anythingToString` function: + +```haskell +anythingToString :: a -> String +``` + + +We test that the result of `anythingToString` is equal to the result of regular +`show` for a large range of data types (including user-defined ones that the +library is not aware of). There are also other possible use cases; for example, +it should be possible to define an `anythingToJSON` function. + +Obviously there are limitations; the most important ones are: + +* `UNPACK`ed fields are invisible to the library. This does not need to be + a major issue though, when compiling code with `-O0` fields are not unpacked. + (https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/exts/pragmas.html?highlight=unpack#nounpack-pragma) +* Record field names are not known, and so records are shown just using the + constructor. + +There may be other gotchas as well; this library is primarily intended +for debugging. diff --git a/recover-rtti.cabal b/recover-rtti.cabal new file mode 100644 --- /dev/null +++ b/recover-rtti.cabal @@ -0,0 +1,87 @@ +cabal-version: 2.4 +name: recover-rtti +version: 0.1.0.0 +synopsis: Recover run-time type information from the GHC heap +description: The main function in this package is 'classify', which looks + at the GHC heap to recover type information about arbitrary + values. This makes it possible for example to show any value + (function 'anythingToString') without having any @Show@ + instance in scope, though there are other use cases as well. + For example, you could use it to define an 'anythingToJSON' + function. +bug-reports: https://github.com/well-typed/recover-rtti/issues +license: BSD-3-Clause +license-file: LICENSE +author: Edsko de Vries +maintainer: edsko@well-typed.com +copyright: Juspay Technologies Pvt Ltd, Well-Typed LLP +category: Debugging +extra-source-files: + README.md + CHANGELOG.md + +Tested-With: GHC ==8.8.4 || ==8.10.4 || ==9.0.1 + +library + exposed-modules: Debug.RecoverRTTI + + -- Other modules exported primarily for the tests + Debug.RecoverRTTI.FlatClosure + Debug.RecoverRTTI.Util + Debug.RecoverRTTI.Util.TypeLevel + + other-modules: Debug.RecoverRTTI.Classifier + Debug.RecoverRTTI.Classify + Debug.RecoverRTTI.ClosureTree + Debug.RecoverRTTI.Constr + Debug.RecoverRTTI.Modules + Debug.RecoverRTTI.Tuple + Debug.RecoverRTTI.Tuple.Recursive + Debug.RecoverRTTI.Tuple.Size + Debug.RecoverRTTI.UserDefined + Debug.RecoverRTTI.Wrappers + build-depends: base >= 4.13 && < 4.16 + , aeson >= 1.5 && < 1.6 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.6 && < 0.7 + , ghc-heap >= 8.8 && < 9.1 + , mtl >= 2.2 && < 2.3 + , sop-core >= 0.5 && < 0.6 + , stm >= 2.5 && < 2.6 + , text >= 1.2 && < 1.3 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + -Wredundant-constraints + +test-suite test-recover-rtti + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: RecoverRttiTests.hs + other-modules: Test.RecoverRTTI.Arbitrary + Test.RecoverRTTI.Classify + Test.RecoverRTTI.ConcreteClassifier + Test.RecoverRTTI.Orphans + Test.RecoverRTTI.Show + Test.RecoverRTTI.Sanity + Test.RecoverRTTI.Staged + Test.RecoverRTTI.UserDefined + build-depends: base >= 4.13 + , recover-rtti + + , aeson + , bytestring + , containers + , ghc-heap + , ghc-prim + , mtl + , QuickCheck + , sop-core + , stm + , tasty + , tasty-quickcheck + , text + , vector + ghc-options: -Wall + -Wno-orphans diff --git a/src/Debug/RecoverRTTI.hs b/src/Debug/RecoverRTTI.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI.hs @@ -0,0 +1,10 @@ +module Debug.RecoverRTTI ( + module X + ) where + +import Debug.RecoverRTTI.Classifier as X +import Debug.RecoverRTTI.Classify as X +import Debug.RecoverRTTI.Constr as X +import Debug.RecoverRTTI.UserDefined as X +import Debug.RecoverRTTI.Wrappers as X +import Debug.RecoverRTTI.Tuple as X diff --git a/src/Debug/RecoverRTTI/Classifier.hs b/src/Debug/RecoverRTTI/Classifier.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/Classifier.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Debug.RecoverRTTI.Classifier ( + Classifier(..) + , Classifiers(..) + , Classified(..) + -- * Partial information + , MaybeF(..) + , EitherF(..) + , MaybePairF(..) + ) where + +import Data.Aeson (Value) +import Data.Int +import Data.IntMap (IntMap) +import Data.IntSet (IntSet) +import Data.Kind +import Data.Map (Map) +import Data.Ratio +import Data.Sequence (Seq) +import Data.Set (Set) +import Data.SOP +import Data.Tree (Tree) +import Data.Void +import Data.Word + +import qualified Data.ByteString as BS.Strict +import qualified Data.ByteString.Lazy as BS.Lazy +import qualified Data.ByteString.Short as BS.Short +import qualified Data.Text as Text.Strict +import qualified Data.Text.Lazy as Text.Lazy + +import Debug.RecoverRTTI.Constr +import Debug.RecoverRTTI.Tuple +import Debug.RecoverRTTI.UserDefined +import Debug.RecoverRTTI.Wrappers +import Debug.RecoverRTTI.Util.TypeLevel + +{------------------------------------------------------------------------------- + Classifier +-------------------------------------------------------------------------------} + +-- | A value along with its classifier +data Classified a = Classified { + classifiedType :: Classifier a + , classifiedValue :: a + } + +-- | Classifier +-- +-- Given a value of some unknown type @a@, a @Classifier a@ will tell you what +-- the type of @a@ is. This is similar to a @TypeRep@, but since we recover +-- this information from the heap, we have less accurate type information than +-- @TypeRep@ does. +data Classifier (a :: Type) :: Type where + -- Primitive types + + C_Bool :: Classifier Bool + C_Char :: Classifier Char + C_Double :: Classifier Double + C_Float :: Classifier Float + C_Int :: Classifier Int + C_Int16 :: Classifier Int16 + C_Int8 :: Classifier Int8 + C_Int32 :: Classifier Int32 + C_Int64 :: Classifier Int64 + C_Integer :: Classifier Integer + C_Ordering :: Classifier Ordering + C_Unit :: Classifier () + C_Word :: Classifier Word + C_Word8 :: Classifier Word8 + C_Word16 :: Classifier Word16 + C_Word32 :: Classifier Word32 + C_Word64 :: Classifier Word64 + + -- String types + -- + -- We list @String@ separately, so that we show them properly (rather than + -- as a list of characters). Of course, empty strings will be inferred as + -- empty lists instead. + + C_String :: Classifier String + C_BS_Strict :: Classifier BS.Strict.ByteString + C_BS_Lazy :: Classifier BS.Lazy.ByteString + C_BS_Short :: Classifier BS.Short.ShortByteString + C_Text_Strict :: Classifier Text.Strict.Text + C_Text_Lazy :: Classifier Text.Lazy.Text + + -- Aeson + + C_Value :: Classifier Value + + -- Compound + + C_Maybe :: MaybeF Classified a -> Classifier (Maybe a) + C_Either :: EitherF Classified a b -> Classifier (Either a b) + C_List :: MaybeF Classified a -> Classifier [a] + C_Ratio :: Classified a -> Classifier (Ratio a) + C_Set :: MaybeF Classified a -> Classifier (Set a) + C_Map :: MaybePairF Classified a b -> Classifier (Map a b) + C_IntSet :: Classifier IntSet + C_IntMap :: MaybeF Classified a -> Classifier (IntMap a) + C_Sequence :: MaybeF Classified a -> Classifier (Seq a) + C_Tree :: Classified a -> Classifier (Tree a) + + C_Tuple :: + (SListI xs, IsValidSize (Length xs)) + => Classifiers xs -> Classifier (WrappedTuple xs) + + -- Reference cells + + C_STRef :: Classifier SomeSTRef + C_TVar :: Classifier SomeTVar + C_MVar :: Classifier SomeMVar + + -- Functions + + C_Fun :: Classifier SomeFun + + -- User-defined + + C_Custom :: Sing c -> Classifier (UserDefined c) + +newtype Classifiers xs = Classifiers (NP Classified xs) + +{------------------------------------------------------------------------------- + Partial information +-------------------------------------------------------------------------------} + +data MaybeF f a where + FNothing :: MaybeF f Void + FJust :: f a -> MaybeF f a + +data EitherF f a b where + FLeft :: f a -> EitherF f a Void + FRight :: f b -> EitherF f Void b + +data MaybePairF f a b where + FNothingPair :: MaybePairF f Void Void + FJustPair :: f a -> f b -> MaybePairF f a b diff --git a/src/Debug/RecoverRTTI/Classify.hs b/src/Debug/RecoverRTTI/Classify.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/Classify.hs @@ -0,0 +1,562 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Debug.RecoverRTTI.Classify ( + -- * Classification + classify + , classified + , fromUserDefined + -- * Showing values + , anythingToString + , canShowClassified + ) where + +import Control.Monad.Except +import Data.IntMap (IntMap) +import Data.Map (Map) +import Data.Sequence (Seq) +import Data.Set (Set) +import Data.SOP +import Data.SOP.Dict +import Data.Tree (Tree) +import GHC.Real +import GHC.Stack +import GHC.Exts.Heap (Closure) +import System.IO.Unsafe (unsafePerformIO) +import Unsafe.Coerce (unsafeCoerce) + +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Tree as Tree + +import Debug.RecoverRTTI.Classifier +import Debug.RecoverRTTI.Constr +import Debug.RecoverRTTI.FlatClosure +import Debug.RecoverRTTI.Modules +import Debug.RecoverRTTI.Tuple +import Debug.RecoverRTTI.UserDefined +import Debug.RecoverRTTI.Util +import Debug.RecoverRTTI.Util.TypeLevel + +{------------------------------------------------------------------------------- + Classification +-------------------------------------------------------------------------------} + +classifyIO :: a -> ExceptT Closure IO (Classifier a) +classifyIO x = do + closure <- lift $ getBoxedClosureData (asBox x) + case closure of + -- + -- Primitive (ghc-prim) + -- + + -- GHC.Types + (inKnownModule GhcTypes -> Just "True") -> return $ mustBe C_Bool + (inKnownModule GhcTypes -> Just "False") -> return $ mustBe C_Bool + (inKnownModule GhcTypes -> Just "C#") -> return $ mustBe C_Char + (inKnownModule GhcTypes -> Just "D#") -> return $ mustBe C_Double + (inKnownModule GhcTypes -> Just "F#") -> return $ mustBe C_Float + (inKnownModule GhcTypes -> Just "I#") -> return $ mustBe C_Int + (inKnownModule GhcTypes -> Just "LT") -> return $ mustBe C_Ordering + (inKnownModule GhcTypes -> Just "GT") -> return $ mustBe C_Ordering + (inKnownModule GhcTypes -> Just "EQ") -> return $ mustBe C_Ordering + (inKnownModule GhcTypes -> Just "W#") -> return $ mustBe C_Word + + -- GHC.Tuple + (inKnownModule GhcTuple -> Just "()") -> return $ mustBe C_Unit + + -- GHC.Int + (inKnownModule GhcInt -> Just "I8#") -> return $ mustBe C_Int8 + (inKnownModule GhcInt -> Just "I16#") -> return $ mustBe C_Int16 + (inKnownModule GhcInt -> Just "I32#") -> return $ mustBe C_Int32 + (inKnownModule GhcInt -> Just "I64#") -> return $ mustBe C_Int64 + + -- GHC.Integer + (inKnownModule GhcIntegerType -> Just "S#") -> return $ mustBe C_Integer + (inKnownModule GhcIntegerType -> Just "Jp#") -> return $ mustBe C_Integer + (inKnownModule GhcIntegerType -> Just "Jn#") -> return $ mustBe C_Integer + (inKnownModule GhcNumInteger -> Just "IS") -> return $ mustBe C_Integer + (inKnownModule GhcNumInteger -> Just "IP") -> return $ mustBe C_Integer + (inKnownModule GhcNumInteger -> Just "IN") -> return $ mustBe C_Integer + + -- GHC.Word + (inKnownModule GhcWord -> Just "W8#") -> return $ mustBe C_Word8 + (inKnownModule GhcWord -> Just "W16#") -> return $ mustBe C_Word16 + (inKnownModule GhcWord -> Just "W32#") -> return $ mustBe C_Word32 + (inKnownModule GhcWord -> Just "W64#") -> return $ mustBe C_Word64 + + -- + -- String types + -- + + -- bytestring + (inKnownModule DataByteStringInternal -> Just "PS") -> return $ mustBe C_BS_Strict + (inKnownModule DataByteStringLazyInternal -> Just "Empty") -> return $ mustBe C_BS_Lazy + (inKnownModule DataByteStringLazyInternal -> Just "Chunk") -> return $ mustBe C_BS_Lazy + (inKnownModule DataByteStringShortInternal -> Just "SBS") -> return $ mustBe C_BS_Short + + -- text + (inKnownModule DataTextInternal -> Just "Text") -> return $ mustBe C_Text_Strict + (inKnownModule DataTextInternalLazy -> Just "Chunk") -> return $ mustBe C_Text_Lazy + (inKnownModule DataTextInternalLazy -> Just "Empty") -> return $ mustBe C_Text_Lazy + + -- + -- Aeson + -- + + (inKnownModule DataAesonTypesInternal -> Just "Object") -> return $ mustBe C_Value + (inKnownModule DataAesonTypesInternal -> Just "Array") -> return $ mustBe C_Value + (inKnownModule DataAesonTypesInternal -> Just "String") -> return $ mustBe C_Value + (inKnownModule DataAesonTypesInternal -> Just "Number") -> return $ mustBe C_Value + (inKnownModule DataAesonTypesInternal -> Just "Bool") -> return $ mustBe C_Value + (inKnownModule DataAesonTypesInternal -> Just "Null") -> return $ mustBe C_Value + + -- + -- Compound (ghc-prim) + -- + + -- Maybe + (inKnownModule GhcMaybe -> Just "Nothing") -> + mustBe <$> classifyMaybe (unsafeCoerce x) + (inKnownModule GhcMaybe -> Just "Just") -> + mustBe <$> classifyMaybe (unsafeCoerce x) + + -- Either + (inKnownModule DataEither -> Just "Left") -> + mustBe <$> classifyEither (unsafeCoerce x) + (inKnownModule DataEither -> Just "Right") -> + mustBe <$> classifyEither (unsafeCoerce x) + + -- Lists (this includes the 'String' case) + (inKnownModule GhcTypes -> Just "[]") -> + mustBe <$> classifyList (unsafeCoerce x) + (inKnownModule GhcTypes -> Just ":") -> + mustBe <$> classifyList (unsafeCoerce x) + + -- Ratio + (inKnownModule GhcReal -> Just ":%") -> + mustBe <$> classifyRatio (unsafeCoerce x) + + -- Set + (inKnownModule DataSetInternal -> Just "Tip") -> + mustBe <$> classifySet (unsafeCoerce x) + (inKnownModule DataSetInternal -> Just "Bin") -> + mustBe <$> classifySet (unsafeCoerce x) + + -- Map + (inKnownModule DataMapInternal -> Just "Tip") -> + mustBe <$> classifyMap (unsafeCoerce x) + (inKnownModule DataMapInternal -> Just "Bin") -> + mustBe <$> classifyMap (unsafeCoerce x) + + -- IntSet + (inKnownModule DataIntSetInternal -> Just "Bin") -> + return $ mustBe $ C_IntSet + (inKnownModule DataIntSetInternal -> Just "Tip") -> + return $ mustBe $ C_IntSet + (inKnownModule DataIntSetInternal -> Just "Nil") -> + return $ mustBe $ C_IntSet + + -- IntMap + (inKnownModule DataIntMapInternal -> Just "Nil") -> + mustBe <$> classifyIntMap (unsafeCoerce x) + (inKnownModule DataIntMapInternal -> Just "Tip") -> + mustBe <$> classifyIntMap (unsafeCoerce x) + (inKnownModule DataIntMapInternal -> Just "Bin") -> + mustBe <$> classifyIntMap (unsafeCoerce x) + + -- Sequence + (inKnownModule DataSequenceInternal -> Just "EmptyT") -> + mustBe <$> classifySequence (unsafeCoerce x) + (inKnownModule DataSequenceInternal -> Just "Single") -> + mustBe <$> classifySequence (unsafeCoerce x) + (inKnownModule DataSequenceInternal -> Just "Deep") -> + mustBe <$> classifySequence (unsafeCoerce x) + + -- Tree + (inKnownModule DataTree -> Just "Node") -> + mustBe <$> classifyTree (unsafeCoerce x) + + -- Tuples (of size 2..62) + (inKnownModuleNested GhcTuple -> Just ( + isTuple -> Just (Some validSize@(ValidSize sz _)) + , verifySize sz -> Just (VerifiedSize ptrs) + )) -> + case liftValidSize validSize of + Dict -> mustBe <$> classifyTuple ptrs + + -- + -- Reference cells + -- + + (inKnownModule GhcSTRef -> Just "STRef") -> return $ mustBe C_STRef + (inKnownModule GhcMVar -> Just "MVar") -> return $ mustBe C_MVar + (inKnownModule GhcConcSync -> Just "TVar") -> return $ mustBe C_TVar + + -- + -- Functions + -- + + FunClosure {} -> return $ mustBe C_Fun + + -- + -- User defined + -- + + ConstrClosure {pkg, modl, name} -> + elimKnownConstr (Constr pkg modl name) $ \p -> + return $ mustBe (C_Custom p) + + -- + -- Classification failed + -- + + OtherClosure other -> ExceptT $ return (Left other) + +mustBe :: Classifier b -> Classifier a +mustBe = unsafeCoerce + +-- | Classify a value +-- +-- Given a value of some unknown type @a@ and a classifier @Classifier a@, +-- it should be sound to coerce the value to the type indicated by the +-- classifier. +-- +-- This is also the reason not all values can be classified; in particular, +-- we cannot classify values of unlifted types, as for these types coercion +-- does not work (this would result in a ghc runtime crash). +classify :: a -> Either Closure (Classifier a) +classify = unsafePerformIO . runExceptT . classifyIO + +{------------------------------------------------------------------------------- + Classification for compound types +-------------------------------------------------------------------------------} + +classifyMaybe :: Maybe a -> ExceptT Closure IO (Classifier (Maybe a)) +classifyMaybe x = + case x of + Nothing -> return $ mustBe $ C_Maybe FNothing + Just x' -> do + cx <- classifyIO x' + return $ mustBe $ C_Maybe (FJust (Classified cx x')) + +classifyEither :: Either a b -> ExceptT Closure IO (Classifier (Either a b)) +classifyEither x = + case x of + Left x' -> do + cx <- classifyIO x' + return $ mustBe $ C_Either (FLeft (Classified cx x')) + Right y' -> do + cy <- classifyIO y' + return $ mustBe $ C_Either (FRight (Classified cy y')) + +classifyList :: [a] -> ExceptT Closure IO (Classifier [a]) +classifyList x = + case x of + [] -> return $ mustBe $ C_List FNothing + x':_ -> do + cx <- classifyIO x' + return $ case cx of + C_Char -> mustBe $ C_String + _otherwise -> mustBe $ C_List (FJust (Classified cx x')) + +classifyRatio :: Ratio a -> ExceptT Closure IO (Classifier (Ratio a)) +classifyRatio (x' :% _) = do + cx <- classifyIO x' + return $ mustBe $ C_Ratio (Classified cx x') + +classifySet :: Set a -> ExceptT Closure IO (Classifier (Set a)) +classifySet x = + case Set.lookupMin x of + Nothing -> return $ mustBe $ C_Set FNothing + Just x' -> do + cx <- classifyIO x' + return $ mustBe $ C_Set (FJust (Classified cx x')) + +classifyMap :: Map a b -> ExceptT Closure IO (Classifier (Map a b)) +classifyMap x = + case Map.lookupMin x of + Nothing -> return $ mustBe $ C_Map FNothingPair + Just (x', y') -> do + cx <- classifyIO x' + cy <- classifyIO y' + return $ mustBe $ C_Map (FJustPair (Classified cx x') (Classified cy y')) + +classifyIntMap :: IntMap a -> ExceptT Closure IO (Classifier (IntMap a)) +classifyIntMap x = + case IntMap.minView x of + Nothing -> return $ mustBe $ C_IntMap FNothing + Just (x', _) -> do + cx <- classifyIO x' + return $ mustBe $ C_IntMap (FJust (Classified cx x')) + +classifySequence :: Seq a -> ExceptT Closure IO (Classifier (Seq a)) +classifySequence x = + case Seq.viewl x of + Seq.EmptyL -> return $ mustBe $ C_Sequence FNothing + x' Seq.:< _ -> do + cx <- classifyIO x' + return $ mustBe $ C_Sequence (FJust (Classified cx x')) + +classifyTree :: Tree a -> ExceptT Closure IO (Classifier (Tree a)) +classifyTree x = + case x of + Tree.Node x' _ -> do + cx <- classifyIO x' + return $ mustBe $ C_Tree (Classified cx x') + +classifyTuple :: + (SListI xs, IsValidSize (Length xs)) + => NP (K Box) xs + -> ExceptT Closure IO (Classifier (WrappedTuple xs)) +classifyTuple ptrs = do + cs <- hsequence' (hmap aux ptrs) + return $ C_Tuple (Classifiers cs) + where + aux :: K Box a -> (ExceptT Closure IO :.: Classified) a + aux (K (Box x)) = Comp $ do + c <- classifyIO (unsafeCoerce x) + return $ Classified c (unsafeCoerce x) + +{------------------------------------------------------------------------------- + Recognizing tuples +-------------------------------------------------------------------------------} + +isTuple :: String -> Maybe (Some ValidSize) +isTuple typ = do + (a, xs, z) <- dropEnds typ + guard $ a == '(' && all (== ',') xs && z == ')' + toValidSize (length xs + 1) + +{------------------------------------------------------------------------------- + Classified values +-------------------------------------------------------------------------------} + +classified :: a -> Either Closure (Classified a) +classified x = (\cx -> Classified cx x) <$> classify x + +{------------------------------------------------------------------------------- + Classify constructor arguments +-------------------------------------------------------------------------------} + +-- | Classify the arguments to the constructor +-- +-- We only look at pointers and ignore any @UNPACK@ed data. Arguments we cannot +-- classify (like unlifted arguments) will be ignored. +fromUserDefined :: forall c. + (HasCallStack, KnownConstr c) + => UserDefined c -> [Some Classified] +fromUserDefined = \(UserDefined x) -> unsafePerformIO $ go x + where + go :: x -> IO [Some Classified] + go x = do + closure <- getBoxedClosureData (asBox x) + case closure of + ConstrClosure {pkg, modl, name, ptrArgs} -> do + let expected, actual :: Constr String + expected = knownConstr (sing @_ @c) + actual = Constr pkg modl name + if expected == actual then do + goArgs [] ptrArgs + else do +-- tree <- showClosureTree 5 x + error $ unlines [ + "elimUserDefined: unexpected constructor" + , " closure: " ++ show closure + , " expected: " ++ show expected + , " actual: " ++ show actual +-- , "** TREE **" +-- , tree +-- , "** END OF TREE **" + ] + _otherwise -> + error $ "elimUserDefined: unexpected closure: " + ++ show closure + + goArgs :: [Some Classified] -> [Box] -> IO [Some Classified] + goArgs acc [] = return (reverse acc) + goArgs acc (Box b:bs) = do + mc <- runExceptT $ classifyIO b + case mc of + Right c -> goArgs (Some (Classified c (unsafeCoerce b)) : acc) bs + Left _ -> goArgs acc bs + +{------------------------------------------------------------------------------- + Show + + Showing values is mutually recursive with classification: when we show a + value classified as @UserDefined@, we recursively classify the nested values + /when/ we show the value. +-------------------------------------------------------------------------------} + +-- | Show any value +-- +-- This shows any value, as long as it's not unlifted. The result should be +-- equal to show instances, with the following caveats: +-- +-- * User-defined types (types not explicitly known to this library) with a +-- /custom/ Show instance will still be showable, but the result will be +-- what the /derived/ show instance would have done. +-- * Record field names are not known at runtime, so they are not shown. +-- * UNPACKed data is not visible to this library (if you compile with @-O0@ +-- @gch@ will not unpack data, so that might be a workaround if necessary). +-- +-- If classification fails, we show the actual closure. +anythingToString :: forall a. a -> String +anythingToString x = + case classified x of + Right classifier -> showClassifiedValue 0 classifier "" + Left closure -> show closure + +deriving instance Show (Classifier a) +deriving instance Show (MaybeF Classified a) +deriving instance Show (EitherF Classified a b) +deriving instance Show (MaybePairF Classified a b) +deriving instance Show (Some Classified) + +instance Show (Classified a) where + showsPrec p (Classified c x) = showParen (p >= 11) $ + case canShowClassified c of + Dict -> + showString "Classified " + . showsPrec 11 c + . showString " " + . showsPrec 11 x + +instance SListI xs => Show (Classifiers xs) where + show (Classifiers xs) = go (hpure Dict) + where + go :: NP (Dict (Compose Show Classified)) xs -> String + go dicts = + case all_NP dicts of + Dict -> "(" ++ show xs ++ ")" + +-- | Show the classified value (without the classifier) +showClassifiedValue :: Int -> Classified a -> ShowS +showClassifiedValue p (Classified c x) = + case canShowClassified c of + Dict -> showsPrec p x + +canShowClassified :: Classifier a -> Dict Show a +canShowClassified = go + where + go :: Classifier a -> Dict Show a + + -- + -- Simple cases + -- + + -- Primitive types + go C_Bool = Dict + go C_Char = Dict + go C_Double = Dict + go C_Float = Dict + go C_Int = Dict + go C_Int16 = Dict + go C_Int8 = Dict + go C_Int32 = Dict + go C_Int64 = Dict + go C_Integer = Dict + go C_Ordering = Dict + go C_Unit = Dict + go C_Word = Dict + go C_Word8 = Dict + go C_Word16 = Dict + go C_Word32 = Dict + go C_Word64 = Dict + + -- String types + go C_String = Dict + go C_BS_Strict = Dict + go C_BS_Lazy = Dict + go C_BS_Short = Dict + go C_Text_Strict = Dict + go C_Text_Lazy = Dict + + -- Aeson + go C_Value = Dict + + -- Reference cells + go C_STRef = Dict + go C_TVar = Dict + go C_MVar = Dict + + -- Functions + go C_Fun = Dict + + -- User-defined + go (C_Custom SConstr) = Dict + + -- + -- Compound + -- + + go (C_Maybe c) = goMaybeF c + go (C_Either c) = goEitherF c + go (C_List c) = goMaybeF c + go (C_Ratio c) = goF c + go (C_Set c) = goMaybeF c + go (C_Map c) = goMaybePairF c + go C_IntSet = Dict + go (C_IntMap c) = goMaybeF c + go (C_Sequence c) = goMaybeF c + go (C_Tree c) = goF c + + go (C_Tuple (Classifiers cs)) = + case all_NP (hmap (canShowClassified . classifiedType) cs) of + Dict -> Dict + + goMaybeF :: forall f a. + (forall x. Show x => Show (f x)) + => MaybeF Classified a -> Dict Show (f a) + goMaybeF FNothing = Dict + goMaybeF (FJust c) = case go (classifiedType c) of + Dict -> Dict + + goEitherF :: forall f a b. + (forall x y. (Show x, Show y) => Show (f x y)) + => EitherF Classified a b -> Dict Show (f a b) + goEitherF (FLeft c) = case go (classifiedType c) of + Dict -> Dict + goEitherF (FRight c) = case go (classifiedType c) of + Dict -> Dict + + goF :: forall f a. + (forall x. Show x => Show (f x)) + => Classified a -> Dict Show (f a ) + goF c = case go (classifiedType c) of + Dict -> Dict + + goMaybePairF :: forall f a b. + (forall x y. (Show x, Show y) => Show (f x y)) + => MaybePairF Classified a b -> Dict Show (f a b) + goMaybePairF FNothingPair = Dict + goMaybePairF (FJustPair c c') = case ( go (classifiedType c) + , go (classifiedType c') + ) of + (Dict, Dict) -> Dict + +instance KnownConstr c => Show (UserDefined c) where + showsPrec p x = + case fromUserDefined x of + [] -> showString constrName + xs -> showParen (p >= 11) + . (showString constrName .) + . foldl (.) id + . map (\(Some x') -> showString " " . showClassifiedValue 11 x') + $ xs + where + Constr{constrName} = knownConstr (sing @_ @c) diff --git a/src/Debug/RecoverRTTI/ClosureTree.hs b/src/Debug/RecoverRTTI/ClosureTree.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/ClosureTree.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE BangPatterns #-} + +module Debug.RecoverRTTI.ClosureTree ( + showClosureTree + ) where + +import Data.List +import GHC.Exts.Heap + +-- | Show closure tree up to the given depth +-- +-- Used only for internal debugging +showClosureTree :: Int -> a -> IO String +showClosureTree = \d -> go d 0 . asBox + where + go :: Int -> Int -> Box -> IO String + go 0 _ _ = return "" + go d i x@(Box !_) = do + closure <- getBoxedClosureData x + render closure <$> mapM (go (d - 1) (i + 2)) (allClosures closure) + where + render :: Closure -> [String] -> String + render closure nested = intercalate "\n" $ + (replicate i ' ' ++ show closure) + : nested diff --git a/src/Debug/RecoverRTTI/Constr.hs b/src/Debug/RecoverRTTI/Constr.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/Constr.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +-- | Type-level metadata +module Debug.RecoverRTTI.Constr ( + Constr(..) + , KnownConstr + , knownConstr + , prettyKnownConstr + , elimKnownConstr + -- | Compute all known constructors + , Constrs + , GConstrs + , GConstrsOfType + , ConstrOf + , IsConstrOf(..) + , checkIsConstrOf + , Sing(..) + ) where + +import Data.Kind +import Data.List (intercalate) +import Data.SOP +import Data.Type.Equality +import GHC.Generics +import GHC.TypeLits + +import Debug.RecoverRTTI.Util +import Debug.RecoverRTTI.Util.TypeLevel + +{------------------------------------------------------------------------------- + Type-level metadata +-------------------------------------------------------------------------------} + +data Constr a = Constr { + constrPkg :: a + , constrModl :: a + , constrName :: a + } + deriving (Show, Eq) + +type family ConstrPkg (c :: Constr a) :: a where ConstrPkg ('Constr p _ _) = p +type family ConstrModl (c :: Constr a) :: a where ConstrModl ('Constr _ m _) = m +type family ConstrName (c :: Constr a) :: a where ConstrName ('Constr _ _ c) = c + +class ( + KnownSymbol (ConstrPkg c) + , KnownSymbol (ConstrModl c) + , KnownSymbol (ConstrName c) + , c ~ 'Constr (ConstrPkg c) (ConstrModl c) (ConstrName c) + ) => KnownConstr c +instance ( + KnownSymbol (ConstrPkg c) + , KnownSymbol (ConstrModl c) + , KnownSymbol (ConstrName c) + , c ~ 'Constr (ConstrPkg c) (ConstrModl c) (ConstrName c) + ) => KnownConstr c + +knownConstr :: + forall c. Sing (c :: Constr Symbol) -> Constr String +knownConstr SConstr = Constr { + constrPkg = symbolVal (Proxy @(ConstrPkg c)) + , constrModl = symbolVal (Proxy @(ConstrModl c)) + , constrName = symbolVal (Proxy @(ConstrName c)) + } + +prettyKnownConstr :: Sing (c :: Constr Symbol) -> String +prettyKnownConstr s = intercalate "." [constrPkg, constrModl, constrName] + where + Constr{constrPkg, constrModl, constrName} = knownConstr s + +elimKnownConstr :: forall r. + Constr String + -> (forall c. Sing (c :: Constr Symbol) -> r) + -> r +elimKnownConstr Constr{constrPkg, constrModl, constrName} k = + elimKnownSymbol constrPkg $ \pPkg -> + elimKnownSymbol constrModl $ \pModl -> + elimKnownSymbol constrName $ \pName -> + go pPkg pModl pName + where + go :: forall pkg modl constr. ( + KnownSymbol pkg + , KnownSymbol modl + , KnownSymbol constr + ) + => Proxy pkg -> Proxy modl -> Proxy constr -> r + go _ _ _ = k (sing :: Sing ('Constr pkg modl constr)) + +{------------------------------------------------------------------------------- + Singleton +-------------------------------------------------------------------------------} + +data instance Sing (c :: Constr Symbol) where + SConstr :: KnownConstr c => Sing c + +instance KnownConstr c => SingI (c :: Constr Symbol) where + sing = SConstr + +instance Show (Sing (c :: Constr Symbol)) where + showsPrec p proxy = showParen (p >= 11) $ + showString "SConstr " + . showsPrec 11 (knownConstr proxy) + +instance DecidableEquality (Constr Symbol) where + decideEquality :: forall c c'. + Sing (c :: Constr Symbol) + -> Sing (c' :: Constr Symbol) + -> Maybe (c :~: c') + decideEquality SConstr SConstr = + case ( decideEquality (sing :: Sing (ConstrPkg c)) (sing :: Sing (ConstrPkg c')) + , decideEquality (sing :: Sing (ConstrModl c)) (sing :: Sing (ConstrModl c')) + , decideEquality (sing :: Sing (ConstrName c)) (sing :: Sing (ConstrName c')) + ) of + (Just Refl, Just Refl, Just Refl) -> + Just Refl + _otherwise -> + Nothing + +{------------------------------------------------------------------------------- + Reverse direction: from type to the known constructors +-------------------------------------------------------------------------------} + +-- | Compute all constructors of the given type +type family Constrs (a :: Type) :: [Constr Symbol] where + Constrs a = GConstrs (Rep a) + +type family GConstrs f :: [Constr Symbol] where + GConstrs (M1 D ('MetaData typ modl pkg isNewtype) f) = + GConstrsOfType pkg modl f '[] + +type family GConstrsOfType pkg modl f acc :: [Constr Symbol] where + GConstrsOfType pkg modl (f :+: g) acc = + GConstrsOfType pkg modl g (GConstrsOfType pkg modl f acc) + GConstrsOfType pkg modl (M1 C ('MetaCons constr fixity isRecord) f) acc = + 'Constr pkg modl constr ': acc + +-- | Require that specified type has the given constructor +-- +-- Intended usage: +-- +-- > castUserDefined :: forall c a. ConstrOf a c => UserDefined c -> a +-- > castUserDefined = unsafeCoerce +type family ConstrOf (a :: Type) (c :: Constr Symbol) :: Constraint where + ConstrOf a c = + Assert + (Elem c (Constrs a)) + (TypeError ( + ( 'ShowType c + ':<>: 'Text " is not a valid constructor of " + ':<>: 'ShowType a + ) + ':$$: ( 'Text "Valid constructors are: " + ':<>: 'ShowType (Constrs a) + ) + )) + +data IsConstrOf (a :: Type) (c :: Constr Symbol) where + IsConstrOf :: Elem c (Constrs a) ~ 'True => IsConstrOf a c + +checkIsConstrOf :: forall (a :: Type) (c :: Constr Symbol). + SingI (Constrs a) + => Sing c -> Maybe (IsConstrOf a c) +checkIsConstrOf s = + aux <$> checkIsElem s (sing @_ @(Constrs a)) + where + aux :: IsElem c (Constrs a) -> IsConstrOf a c + aux IsElem = IsConstrOf diff --git a/src/Debug/RecoverRTTI/FlatClosure.hs b/src/Debug/RecoverRTTI/FlatClosure.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/FlatClosure.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Debug.RecoverRTTI.FlatClosure ( + FlatClosure(..) + , getBoxedClosureData + -- * Re-exports + , Box(..) + , asBox + ) where + +import Control.Exception (evaluate) +import Control.Monad +import GHC.Exts.Heap (Box(..), asBox) +import qualified GHC.Exts.Heap as H + +-- | Flattened form of 'Closure' (with indirection nodes removed) +-- +-- We only include the fields of 'Closure' that we are interested in. +-- +-- TODO: For functions ('FunClosure', 'PAPClosure') we don't currently include +-- any information at all. We could potentially do better here. +data FlatClosure = + -- | Constructor application + ConstrClosure { + ptrArgs :: [Box] + , pkg :: String + , modl :: String + , name :: String + } + + -- | Functions + -- + -- We map 'H.FunClosure', 'H.PAPClosure' and H.BCOClosure' all to this. + | FunClosure + + -- | Unrecognized closure type + | OtherClosure H.Closure + deriving (Show) + +getBoxedClosureData :: Box -> IO FlatClosure +getBoxedClosureData b = do + tryForceBox b + fromClosure =<< H.getBoxedClosureData b + where + fromClosure :: H.Closure -> IO FlatClosure + fromClosure = \case + -- Indirections + -- + -- For background on black holes, see "Implementing Lazy Functional + -- Languages on Stock Hardware: The Spineless Tagless G-machine", Simon + -- Peyton Jones, Journal of Functional Programming, July 1992, section + -- 9.3.3 "Black holes". + + H.BlackholeClosure _ x' -> getBoxedClosureData x' + H.IndClosure _ x' -> getBoxedClosureData x' + + -- Constructor application + + H.ConstrClosure{ptrArgs, pkg, modl, name} -> + return $ ConstrClosure{..} + + -- Functions + + H.FunClosure{} -> return $ FunClosure + H.PAPClosure{} -> return $ FunClosure + H.BCOClosure{} -> return $ FunClosure + + -- Other kinds of constructors + + otherClosure -> + return $ OtherClosure otherClosure + +-- | Force the value to WHNF, if possible +-- +-- We /cannot/ force the argument until we know what kind of closure we're +-- dealing with. If this is an unlifted closure, forcing it will result in a +-- ghc runtime crash. +tryForceBox :: Box -> IO () +tryForceBox b@(Box x) = do + closure <- H.getBoxedClosureData b + case closure of + + H.APClosure{} -> void $ evaluate x + H.ThunkClosure{} -> void $ evaluate x + H.SelectorClosure{} -> void $ evaluate x + _otherwise -> return () diff --git a/src/Debug/RecoverRTTI/Modules.hs b/src/Debug/RecoverRTTI/Modules.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/Modules.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Modules we recognize types from +module Debug.RecoverRTTI.Modules ( + KnownPkg(..) + , KnownModule(..) + , Sing(..) + -- * Matching + , inKnownModule + , inKnownModuleNested + ) where + +import Control.Monad +import Data.List (isPrefixOf) + +import Debug.RecoverRTTI.FlatClosure +import Debug.RecoverRTTI.Util.TypeLevel + +{------------------------------------------------------------------------------- + Packages +-------------------------------------------------------------------------------} + +data KnownPkg = + PkgGhcPrim + | PkgBase + | PkgByteString + | PkgText + | PkgIntegerWiredIn + | PkgGhcBignum + | PkgContainers + | PkgAeson + +data family KnownModule (pkg :: KnownPkg) + +{------------------------------------------------------------------------------- + Singleton instance for KnownPkg +-------------------------------------------------------------------------------} + +data instance Sing (pkg :: KnownPkg) where + SGhcPrim :: Sing 'PkgGhcPrim + SBase :: Sing 'PkgBase + SByteString :: Sing 'PkgByteString + SText :: Sing 'PkgText + SIntegerWiredIn :: Sing 'PkgIntegerWiredIn + SGhcBignum :: Sing 'PkgGhcBignum + SContainers :: Sing 'PkgContainers + SAeson :: Sing 'PkgAeson + +instance SingI 'PkgGhcPrim where sing = SGhcPrim +instance SingI 'PkgBase where sing = SBase +instance SingI 'PkgByteString where sing = SByteString +instance SingI 'PkgText where sing = SText +instance SingI 'PkgIntegerWiredIn where sing = SIntegerWiredIn +instance SingI 'PkgGhcBignum where sing = SGhcBignum +instance SingI 'PkgContainers where sing = SContainers +instance SingI 'PkgAeson where sing = SAeson + +{------------------------------------------------------------------------------- + Modules in @ghc-pri@ +-------------------------------------------------------------------------------} + +data instance KnownModule 'PkgGhcPrim = + GhcTypes + | GhcTuple + +{------------------------------------------------------------------------------- + Modules in @base@ +-------------------------------------------------------------------------------} + +data instance KnownModule 'PkgBase = + GhcInt + | GhcWord + | GhcSTRef + | GhcMVar + | GhcConcSync + | GhcMaybe + | GhcReal + | DataEither + +{------------------------------------------------------------------------------- + Modules in @bytestring@ +-------------------------------------------------------------------------------} + +data instance KnownModule 'PkgByteString = + DataByteStringInternal + | DataByteStringLazyInternal + | DataByteStringShortInternal + +{------------------------------------------------------------------------------- + Modules in @text@ +-------------------------------------------------------------------------------} + +data instance KnownModule 'PkgText = + DataTextInternal + | DataTextInternalLazy + +{------------------------------------------------------------------------------- + Modules in @integer-wired-in@ (this is a virtual package) +-------------------------------------------------------------------------------} + +data instance KnownModule 'PkgIntegerWiredIn = + GhcIntegerType + +{------------------------------------------------------------------------------- + Modules in @ghc-bignum@ +-------------------------------------------------------------------------------} + +data instance KnownModule 'PkgGhcBignum = + GhcNumInteger + +{------------------------------------------------------------------------------- + Modules in @containers@ +-------------------------------------------------------------------------------} + +data instance KnownModule 'PkgContainers = + DataSetInternal + | DataMapInternal + | DataIntSetInternal + | DataIntMapInternal + | DataSequenceInternal + | DataTree + +{------------------------------------------------------------------------------- + Modules in @aeson@ +-------------------------------------------------------------------------------} + +data instance KnownModule 'PkgAeson = + DataAesonTypesInternal + +{------------------------------------------------------------------------------- + Matching +-------------------------------------------------------------------------------} + +-- | Check if the given closure is from a known package/module +inKnownModule :: SingI pkg + => KnownModule pkg + -> FlatClosure -> Maybe String +inKnownModule modl = fmap fst . inKnownModuleNested modl + +-- | Generalization of 'inKnownModule' that additionally returns nested pointers +inKnownModuleNested :: SingI pkg + => KnownModule pkg + -> FlatClosure -> Maybe (String, [Box]) +inKnownModuleNested = go sing + where + go :: Sing pkg -> KnownModule pkg -> FlatClosure -> Maybe (String, [Box]) + go knownPkg knownModl ConstrClosure{pkg, modl, name, ptrArgs} = do + guard (namePkg knownPkg `isPrefixOf` pkg) -- ignore the version number + guard (modl == nameModl knownPkg knownModl) + return (name, ptrArgs) + go _ _ _otherClosure = Nothing + + namePkg :: Sing (pkg :: KnownPkg) -> String + namePkg SGhcPrim = "ghc-prim" + namePkg SBase = "base" + namePkg SByteString = "bytestring" + namePkg SText = "text" + namePkg SIntegerWiredIn = "integer-wired-in" + namePkg SGhcBignum = "ghc-bignum" + namePkg SContainers = "containers" + namePkg SAeson = "aeson" + + nameModl :: Sing (pkg :: KnownPkg) -> KnownModule pkg -> String + nameModl SGhcPrim GhcTypes = "GHC.Types" + nameModl SGhcPrim GhcTuple = "GHC.Tuple" + nameModl SBase GhcInt = "GHC.Int" + nameModl SBase GhcWord = "GHC.Word" + nameModl SBase GhcSTRef = "GHC.STRef" + nameModl SBase GhcMVar = "GHC.MVar" + nameModl SBase GhcConcSync = "GHC.Conc.Sync" + nameModl SBase GhcMaybe = "GHC.Maybe" + nameModl SBase GhcReal = "GHC.Real" + nameModl SBase DataEither = "Data.Either" + nameModl SByteString DataByteStringInternal = "Data.ByteString.Internal" + nameModl SByteString DataByteStringLazyInternal = "Data.ByteString.Lazy.Internal" + nameModl SByteString DataByteStringShortInternal = "Data.ByteString.Short.Internal" + nameModl SText DataTextInternal = "Data.Text.Internal" + nameModl SText DataTextInternalLazy = "Data.Text.Internal.Lazy" + nameModl SIntegerWiredIn GhcIntegerType = "GHC.Integer.Type" + nameModl SGhcBignum GhcNumInteger = "GHC.Num.Integer" + nameModl SContainers DataSetInternal = "Data.Set.Internal" + nameModl SContainers DataMapInternal = "Data.Map.Internal" + nameModl SContainers DataIntSetInternal = "Data.IntSet.Internal" + nameModl SContainers DataIntMapInternal = "Data.IntMap.Internal" + nameModl SContainers DataSequenceInternal = "Data.Sequence.Internal" + nameModl SContainers DataTree = "Data.Tree" + nameModl SAeson DataAesonTypesInternal = "Data.Aeson.Types.Internal" diff --git a/src/Debug/RecoverRTTI/Tuple.hs b/src/Debug/RecoverRTTI/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/Tuple.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Debug.RecoverRTTI.Tuple ( + -- * Wrapped tuple + WrappedTuple(WrappedTuple, TNil, TCons) + -- * Auxiliary + , bimapTuple + -- * Conversion between tuples and NP + , tupleFromNP + , tupleToNP + -- * Re-exports + , module Debug.RecoverRTTI.Tuple.Recursive + , module Debug.RecoverRTTI.Tuple.Size + ) where + +import Data.SOP hiding (NS(..)) + +import Debug.RecoverRTTI.Tuple.Recursive +import Debug.RecoverRTTI.Tuple.Size +import Debug.RecoverRTTI.Util.TypeLevel + +{------------------------------------------------------------------------------- + Wrapped tuple + + NOTE: We cannot add any dictionaries in @WrappedTuple@ itself, it /MUST/ be + a type synonym: it is critical that we can 'unsafeCoerce' a regular tuple to a + wrapped tuple. +-------------------------------------------------------------------------------} + +newtype WrappedTuple xs = WrappedTuple (Tuple xs) + +pattern TNil :: + forall xs. (SListI xs, IsValidSize (Length xs)) + => xs ~ '[] + => WrappedTuple xs +pattern TNil <- (viewWrapped -> TupleEmpty) + where + TNil = WrappedTuple () + +pattern TCons :: + forall xs'. (SListI xs', IsValidSize (Length xs')) + => forall x xs . (xs' ~ (x ': xs), SListI xs, IsValidSize (Length xs)) + => x -> WrappedTuple xs -> WrappedTuple xs' +pattern TCons x xs <- (viewWrapped -> TupleNonEmpty x xs) + where + TCons x xs = consWrapped (x, xs) + +{-# COMPLETE TNil, TCons #-} + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +bimapTuple :: + ( SListI xs + , SListI ys + , IsValidSize (Length (x ': xs)) + , Length xs ~ Length ys + ) + => (x -> y) + -> (WrappedTuple xs -> WrappedTuple ys) + -> WrappedTuple (x ': xs) -> WrappedTuple (y ': ys) +bimapTuple f g (TCons x xs) = TCons (f x) (g xs) + +{------------------------------------------------------------------------------- + Conversion to/from NP +-------------------------------------------------------------------------------} + +tupleFromNP :: forall xs. + (SListI xs, IsValidSize (Length xs)) + => NP I xs -> WrappedTuple xs +tupleFromNP Nil = TNil +tupleFromNP (I x :* xs) = smallerIsValid (Proxy @(Length xs)) + $ TCons x (tupleFromNP xs) + +tupleToNP :: + (SListI xs, IsValidSize (Length xs)) + => WrappedTuple xs -> NP I xs +tupleToNP TNil = Nil +tupleToNP (TCons x xs) = I x :* tupleToNP xs + +{------------------------------------------------------------------------------- + Internal auxiliary functions for defining the pattern synonym +-------------------------------------------------------------------------------} + +data TupleView xs where + TupleEmpty :: TupleView '[] + TupleNonEmpty :: (SListI xs, IsValidSize (Length xs)) + => x -> WrappedTuple xs -> TupleView (x ': xs) + +viewWrapped :: + (SListI xs, IsValidSize (Length xs)) + => WrappedTuple xs + -> TupleView xs +viewWrapped (WrappedTuple t) = + go sList t + where + go :: forall xs. + IsValidSize (Length xs) + => SList xs -> Tuple xs -> TupleView xs + go SNil () = TupleEmpty + go SCons xs = goCons xs + + goCons :: forall x xs. + (SListI xs, IsValidSize (Length (x ': xs))) + => Tuple (x ': xs) -> TupleView (x ': xs) + goCons xs = + smallerIsValid (Proxy @(Length (x ': xs))) $ + TupleNonEmpty x (WrappedTuple xs') + where + (x, xs') = uncons (Proxy @xs) isValidSize xs + +consWrapped :: forall x xs. + (SListI xs, IsValidSize (Length (x ': xs))) + => (x, WrappedTuple xs) -> WrappedTuple (x ': xs) +consWrapped (x, WrappedTuple xs) = + WrappedTuple (cons (Proxy @xs) isValidSize (x, xs)) + +{------------------------------------------------------------------------------- + Instances +-------------------------------------------------------------------------------} + +instance ( SListI xs + , IsValidSize (Length xs) + , All Show xs + ) => Show (WrappedTuple xs) where + showsPrec _ = + show_tuple + . hcollapse + . hcmap (Proxy @Show) (mapIK shows) + . tupleToNP + where + -- Copied from @GHC.Show@ (not exported) + show_tuple :: [ShowS] -> ShowS + show_tuple ss = showChar '(' + . foldr1 (\s r -> s . showChar ',' . r) ss + . showChar ')' + +instance ( SListI xs + , IsValidSize (Length xs) + , All Eq xs + ) => Eq (WrappedTuple xs) where + (tupleToNP -> xs) == (tupleToNP -> ys) = + and . hcollapse $ hczipWith (Proxy @Eq) (mapIIK (==)) xs ys diff --git a/src/Debug/RecoverRTTI/Tuple/Recursive.hs b/src/Debug/RecoverRTTI/Tuple/Recursive.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/Tuple/Recursive.hs @@ -0,0 +1,429 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- {-# LANGUAGE UndecidableSuperClasses #-} + +-- Disable the GHC pattern match checker (this makes compilation /much/ faster) +-- +-- Verified that this module compiles without warnings for smaller maximum +-- tuple size. +-- +-- For some details, see +-- +-- * https://gitlab.haskell.org/ghc/ghc/-/issues/17836 +-- * https://gitlab.haskell.org/ghc/ghc/-/issues/16382 +{-# OPTIONS_GHC -Wno-overlapping-patterns -Wno-incomplete-patterns -Wno-incomplete-uni-patterns -fno-opt-coercion #-} + +-- | Provide a recursive views on tuples +module Debug.RecoverRTTI.Tuple.Recursive ( + Tuple + , cons + , uncons + ) where + +import Data.SOP + +import Debug.RecoverRTTI.Tuple.Size +import Debug.RecoverRTTI.Util.TypeLevel + +{------------------------------------------------------------------------------- + Generated +-------------------------------------------------------------------------------} + +type family Tuple xs where + Tuple '[] = + {- 00 -} () + Tuple '[x1] = + {- 01 -} (x1) + Tuple '[x1, x2] = + {- 02 -} (x1, x2) + Tuple '[x1, x2, x3] = + {- 03 -} (x1, x2, x3) + Tuple '[x1, x2, x3, x4] = + {- 04 -} (x1, x2, x3, x4) + Tuple '[x1, x2, x3, x4, x5] = + {- 05 -} (x1, x2, x3, x4, x5) + Tuple '[x1, x2, x3, x4, x5, x6] = + {- 06 -} (x1, x2, x3, x4, x5, x6) + Tuple '[x1, x2, x3, x4, x5, x6, x7] = + {- 07 -} (x1, x2, x3, x4, x5, x6, x7) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8] = + {- 08 -} (x1, x2, x3, x4, x5, x6, x7, x8) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9] = + {- 09 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10] = + {- 10 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11] = + {- 11 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12] = + {- 12 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13] = + {- 13 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14] = + {- 14 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15] = + {- 15 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16] = + {- 16 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17] = + {- 17 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18] = + {- 18 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19] = + {- 19 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20] = + {- 20 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21] = + {- 21 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22] = + {- 22 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23] = + {- 23 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24] = + {- 24 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25] = + {- 25 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26] = + {- 26 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27] = + {- 27 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28] = + {- 28 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29] = + {- 29 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30] = + {- 30 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31] = + {- 31 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32] = + {- 32 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33] = + {- 33 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34] = + {- 34 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35] = + {- 35 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36] = + {- 36 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37] = + {- 37 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38] = + {- 38 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39] = + {- 39 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40] = + {- 40 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41] = + {- 41 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42] = + {- 42 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43] = + {- 43 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44] = + {- 44 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45] = + {- 45 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46] = + {- 46 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47] = + {- 47 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48] = + {- 48 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49] = + {- 49 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50] = + {- 50 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51] = + {- 51 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52] = + {- 52 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53] = + {- 53 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54] = + {- 54 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55] = + {- 55 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56] = + {- 56 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57] = + {- 57 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58] = + {- 58 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59] = + {- 59 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60] = + {- 60 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60, x61] = + {- 61 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60, x61) + Tuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60, x61, x62] = + {- 62 -} (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60, x61, x62) + +cons :: forall x xs. SListI xs + => Proxy xs + -> ValidSize (Length (x ': xs)) + -> (x, Tuple xs) -> Tuple (x ': xs) +cons _ (ValidSize _n notTooBig) = go shape + where + go :: Shape xs -> (x, Tuple xs) -> Tuple (x ': xs) + go ShapeNil (x1, ()) = + (x1) + go (ShapeCons ShapeNil) (x1, (x2)) = + (x1, x2) + go (ShapeCons (ShapeCons ShapeNil)) (x1, (x2, x3)) = + (x1, x2, x3) + go (ShapeCons (ShapeCons (ShapeCons ShapeNil))) (x1, (x2, x3, x4)) = + (x1, x2, x3, x4) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))) (x1, (x2, x3, x4, x5)) = + (x1, x2, x3, x4, x5) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))) (x1, (x2, x3, x4, x5, x6)) = + (x1, x2, x3, x4, x5, x6) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))) (x1, (x2, x3, x4, x5, x6, x7)) = + (x1, x2, x3, x4, x5, x6, x7) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))) (x1, (x2, x3, x4, x5, x6, x7, x8)) = + (x1, x2, x3, x4, x5, x6, x7, x8) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60, x61)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60, x61) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60, x61, x62)) = + (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60, x61, x62) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons _)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) _ = + notTooBig (TooBig :: TooBig (Length (x ': xs))) + +uncons :: forall x xs. SListI xs + => Proxy xs + -> ValidSize (Length (x ': xs)) + -> Tuple (x ': xs) -> (x, Tuple xs) +uncons _ (ValidSize _n notTooBig) = go shape + where + go :: Shape xs -> Tuple (x ': xs) -> (x, Tuple xs) + go ShapeNil (x1) = + (x1, ()) + go (ShapeCons ShapeNil) (x1, x2) = + (x1, (x2)) + go (ShapeCons (ShapeCons ShapeNil)) (x1, x2, x3) = + (x1, (x2, x3)) + go (ShapeCons (ShapeCons (ShapeCons ShapeNil))) (x1, x2, x3, x4) = + (x1, (x2, x3, x4)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))) (x1, x2, x3, x4, x5) = + (x1, (x2, x3, x4, x5)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))) (x1, x2, x3, x4, x5, x6) = + (x1, (x2, x3, x4, x5, x6)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))) (x1, x2, x3, x4, x5, x6, x7) = + (x1, (x2, x3, x4, x5, x6, x7)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))) (x1, x2, x3, x4, x5, x6, x7, x8) = + (x1, (x2, x3, x4, x5, x6, x7, x8)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60, x61) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60, x61)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons ShapeNil))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60, x61, x62) = + (x1, (x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, x28, x29, x30, x31, x32, x33, x34, x35, x36, x37, x38, x39, x40, x41, x42, x43, x44, x45, x46, x47, x48, x49, x50, x51, x52, x53, x54, x55, x56, x57, x58, x59, x60, x61, x62)) + go (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons (ShapeCons _)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) _ = + notTooBig (TooBig :: TooBig (Length (x ': xs))) diff --git a/src/Debug/RecoverRTTI/Tuple/Size.hs b/src/Debug/RecoverRTTI/Tuple/Size.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/Tuple/Size.hs @@ -0,0 +1,517 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-overlapping-patterns -Wno-incomplete-patterns -Wno-incomplete-uni-patterns -fno-opt-coercion #-} + +-- | Valid tuple size +module Debug.RecoverRTTI.Tuple.Size ( + ValidSize(..) + , TooBig(..) + , smallerIsValid + , IsValidSize(..) + , liftValidSize + , toValidSize + ) where + +import Data.Proxy +import Data.SOP.Dict + +import Debug.RecoverRTTI.Util +import Debug.RecoverRTTI.Util.TypeLevel + +{------------------------------------------------------------------------------- + Not generated +-------------------------------------------------------------------------------} + +data ValidSize (n :: Nat) where + ValidSize :: Sing n -> (forall r. TooBig n -> r) -> ValidSize n + +smallerIsValid' :: forall n. ValidSize ('S n) -> ValidSize n +smallerIsValid' = \(ValidSize (SS n) tooBig) -> ValidSize n $ aux tooBig + where + aux :: (TooBig ('S n) -> r) -> TooBig n -> r + aux tooBig TooBig = tooBig (TooBig :: TooBig ('S n)) + +smallerIsValid :: forall n r. + IsValidSize ('S n) + => Proxy ('S n) + -> (IsValidSize n => r) + -> r +smallerIsValid _ k = + case liftValidSize (smallerIsValid' valid) of + Dict -> k + where + valid :: ValidSize ('S n) + valid = isValidSize + +class SingI n => IsValidSize n where + isValidSize :: ValidSize n + +{------------------------------------------------------------------------------- + Generated +-------------------------------------------------------------------------------} + +data TooBig (n :: Nat) where + TooBig :: TooBig ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S n))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + +liftValidSize :: forall n. ValidSize n -> Dict IsValidSize n +liftValidSize (ValidSize n notTooBig) = go n + where + go :: Sing n -> Dict IsValidSize n + go SZ = + Dict + go (SS SZ) = + Dict + go (SS (SS SZ)) = + Dict + go (SS (SS (SS SZ))) = + Dict + go (SS (SS (SS (SS SZ)))) = + Dict + go (SS (SS (SS (SS (SS SZ))))) = + Dict + go (SS (SS (SS (SS (SS (SS SZ)))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS SZ))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS SZ)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) = + Dict + go (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS _))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) = + notTooBig (TooBig :: TooBig n) + +instance IsValidSize 'Z where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S 'Z) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S 'Z)) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S 'Z))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S 'Z)))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S 'Z))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S 'Z)))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S 'Z))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +instance IsValidSize ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) where + isValidSize = ValidSize sing $ \case + +toValidSize :: Int -> Maybe (Some ValidSize) +toValidSize = go + where + go :: Int -> Maybe (Some ValidSize) + go 0 = Just . Some $ + isValidSize @'Z + go 1 = Just . Some $ + isValidSize @('S 'Z) + go 2 = Just . Some $ + isValidSize @('S ('S 'Z)) + go 3 = Just . Some $ + isValidSize @('S ('S ('S 'Z))) + go 4 = Just . Some $ + isValidSize @('S ('S ('S ('S 'Z)))) + go 5 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S 'Z))))) + go 6 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S 'Z)))))) + go 7 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S 'Z))))))) + go 8 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))) + go 9 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))) + go 10 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))) + go 11 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))) + go 12 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))) + go 13 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))) + go 14 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))) + go 15 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))) + go 16 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))) + go 17 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))) + go 18 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))) + go 19 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))) + go 20 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))) + go 21 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))) + go 22 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))) + go 23 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))) + go 24 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))) + go 25 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))) + go 26 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))) + go 27 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))) + go 28 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))) + go 29 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))) + go 30 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))) + go 31 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))) + go 32 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))) + go 33 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))) + go 34 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))) + go 35 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))) + go 36 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))) + go 37 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))) + go 38 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))) + go 39 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))) + go 40 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))) + go 41 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))) + go 42 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))) + go 43 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))) + go 44 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))) + go 45 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))) + go 46 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))) + go 47 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))) + go 48 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))) + go 49 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))) + go 50 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))) + go 51 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))))) + go 52 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))))) + go 53 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))))))) + go 54 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))))))) + go 55 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))))))))) + go 56 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))))))))) + go 57 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + go 58 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + go 59 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + go 60 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + go 61 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + go 62 = Just . Some $ + isValidSize @('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + go _ = Nothing diff --git a/src/Debug/RecoverRTTI/UserDefined.hs b/src/Debug/RecoverRTTI/UserDefined.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/UserDefined.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | User-defined types +-- +-- For user-defined types, we have no way of actually inferring the /type/ at +-- runtime. Instead, we merely reflect (at the type level) which /constructor/ +-- was used to construct the value. This gives the library sufficient context +-- to /show/ values, and it gives client code that /is/ aware of these custom +-- types sufficient context to recover the full type information, if desired. +-- See "Test.RecoverRTTI.Staged" for an example of the latter. +module Debug.RecoverRTTI.UserDefined ( + -- | Type inferred for user-defined types + UserDefined(..) + , unsafeCoerceUserDefined + ) where + +import Data.Proxy +import GHC.TypeLits +import GHC.Exts +import Unsafe.Coerce (unsafeCoerce) + +import Debug.RecoverRTTI.Constr +import Debug.RecoverRTTI.Util + +{------------------------------------------------------------------------------- + User-defined types +-------------------------------------------------------------------------------} + +-- | User-defined type +-- +-- For user-defined types we recover, at the type level, information about the +-- constructor. In /principle/ of course this means that this tells us what +-- the type of this thing is; if +-- +-- > data MyType .. = MyConstr .. | ... +-- +-- then @coerce :: UserDefined "MyConstr" -> MyType@ should be safe. +-- +-- We defer classification of the /arguments/ to the constructor. This is +-- necessary, because if we tried to do this eagerly---recording those types as +-- part of the 'UserDefined' type---we might end up "unwinding" recursive types +-- at the type level; for example, something like +-- +-- > data MyList = MyNil | MyCons a (MyList a) +-- +-- could then result in something like +-- +-- > UserDefined "MyCons" '[ Int, UserDefined "MyCons" '[ Int , ... ] .. ] +-- +-- Detecting recursion is undecidable (that's why Haskell uses isorecursive +-- rather than equirecursive types), so instead we defer. +newtype UserDefined (c :: Constr Symbol) = UserDefined Any + +-- | Safer wrapper around 'unsafeCoerce' +-- +-- This is safer than 'unsafeCoerce', because we require (at the type level) +-- that the value was constructed with a constructor of the target type. This +-- means that 'unsafeCoerceUserDefined' is in fact /safe/ for types without +-- type parameters; however, for a type such as +-- +-- > data MyType a = MkMyType a +-- +-- 'unsafeCoerceUserDefined' can still be used to cast, say, @MyType Int@ to +-- @MyType Bool@, and so this is still unsafe. +unsafeCoerceUserDefined :: forall a c. ConstrOf a c => UserDefined c -> a +unsafeCoerceUserDefined = unsafeCoerce + where + _ = keepRedundantConstraint (Proxy @(ConstrOf a c)) diff --git a/src/Debug/RecoverRTTI/Util.hs b/src/Debug/RecoverRTTI/Util.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/Util.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Debug.RecoverRTTI.Util ( + -- * Existentials + Some(..) + , elimKnownSymbol + -- * Constraints + , keepRedundantConstraint + -- * Traversable + , checkEmptyTraversable + -- * Lists + , dropEnds + -- * SOP + , VerifiedSize(..) + , verifySize + ) where + +import Data.Kind +import Data.Proxy +import Data.SOP +import Data.Void +import GHC.TypeLits (KnownSymbol, SomeSymbol(..), someSymbolVal) + +import Debug.RecoverRTTI.Util.TypeLevel + +{------------------------------------------------------------------------------- + Existentials +-------------------------------------------------------------------------------} + +data Some (f :: k -> Type) where + Some :: forall f a. f a -> Some f + +elimKnownSymbol :: String -> (forall n. KnownSymbol n => Proxy n -> r) -> r +elimKnownSymbol s k = + case someSymbolVal s of + SomeSymbol p -> k p + +{------------------------------------------------------------------------------- + Constraints +-------------------------------------------------------------------------------} + +-- | Can be used to silence individual "redundant constraint" warnings +-- +-- > foo :: ConstraintUsefulForDebugging => ... +-- > foo = +-- > .. +-- > where +-- > _ = keepRedundantConstraint (Proxy @ConstraintUsefulForDebugging)) +keepRedundantConstraint :: c => proxy c -> () +keepRedundantConstraint _ = () + +{------------------------------------------------------------------------------- + Traversable +-------------------------------------------------------------------------------} + +-- | Check if a traversable data structure is empty +-- +-- Returns evidence: an element of the data-structure if it's non-empty, +-- or evidence that it is empty otherwise. +checkEmptyTraversable :: Traversable t => t a -> Either a (t Void) +checkEmptyTraversable = traverse Left + +{------------------------------------------------------------------------------- + Lists +-------------------------------------------------------------------------------} + +-- | Drop the ends of a list +-- +-- > dropEnds "abcde" == Just ('a',"bcd",'e') +dropEnds :: forall a. [a] -> Maybe (a, [a], a) +dropEnds = \case + [] -> Nothing + (a:xs) -> go a xs + where + go :: a -> [a] -> Maybe (a, [a], a) + go a = goRest [] + where + goRest :: [a] -> [a] -> Maybe (a, [a], a) + goRest _ [] = Nothing + goRest acc [z] = Just (a, reverse acc, z) + goRest acc (x:xs) = goRest (x:acc) xs + +{------------------------------------------------------------------------------- + SOP +-------------------------------------------------------------------------------} + +data VerifiedSize (n :: Nat) (a :: Type) where + -- This is intentionally not kind polymorphic + VerifiedSize :: forall n a (xs :: [Type]). + (SListI xs, Length xs ~ n) + => NP (K a) xs -> VerifiedSize n a + +verifySize :: Sing n -> [a] -> Maybe (VerifiedSize n a) +verifySize = go + where + go :: Sing n -> [a] -> Maybe (VerifiedSize n a) + go SZ [] = Just (VerifiedSize Nil) + go (SS n) (x:xs) = do VerifiedSize np <- go n xs + return $ VerifiedSize (K x :* np) + go SZ (_:_) = Nothing + go (SS _) [] = Nothing diff --git a/src/Debug/RecoverRTTI/Util/TypeLevel.hs b/src/Debug/RecoverRTTI/Util/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/Util/TypeLevel.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Debug.RecoverRTTI.Util.TypeLevel ( + -- * Singletons + Sing(..) + , SingI(..) + , DecidableEquality(..) + -- ** Natural numbers + , Nat(..) + , knownNat + , Length + -- * General purpose type level functions + , Or + , Equal + , Elem + , Assert + -- * Type-level membership check + , IsElem(..) + , checkIsElem + -- * Phantom type parameters + , Phantom(..) + , Poly(..) + , maybePoly + ) where + +import Data.Kind +import Data.Proxy +import Data.Type.Equality +import GHC.TypeLits (ErrorMessage, Symbol, KnownSymbol, TypeError, sameSymbol) + +{------------------------------------------------------------------------------- + Singletons +-------------------------------------------------------------------------------} + +data family Sing :: k -> Type + +class SingI (a :: k) where + sing :: Sing a + +class DecidableEquality k where + decideEquality :: Sing (a :: k) -> Sing (b :: k) -> Maybe (a :~: b) + +{------------------------------------------------------------------------------- + For kind 'Type', Sing is just a proxy +-------------------------------------------------------------------------------} + +data instance Sing (a :: Type) where + SProxy :: Sing (a :: Type) + +instance SingI (a :: Type) where + sing = SProxy + +{------------------------------------------------------------------------------- + Natural numbers + + Unlike @ghc@'s, these are inductively defined. +-------------------------------------------------------------------------------} + +data Nat = Z | S Nat + +data instance Sing (n :: Nat) where + SZ :: Sing 'Z + SS :: Sing n -> Sing ('S n) + +instance SingI 'Z where sing = SZ +instance SingI n => SingI ('S n) where sing = SS sing + +knownNat :: Sing (n :: Nat) -> Int +knownNat SZ = 0 +knownNat (SS n) = knownNat n + 1 + +type family Length (xs :: [k]) :: Nat where + Length '[] = 'Z + Length (_ ': xs) = 'S (Length xs) + +{------------------------------------------------------------------------------- + Singleton instance for type-level symbols +-------------------------------------------------------------------------------} + +data instance Sing (n :: Symbol) where + SSymbol :: KnownSymbol n => Sing n + +instance KnownSymbol n => SingI (n :: Symbol) where + sing = SSymbol + +instance DecidableEquality Symbol where + decideEquality SSymbol SSymbol = sameSymbol Proxy Proxy + +{------------------------------------------------------------------------------- + Singleton instance for lists +-------------------------------------------------------------------------------} + +data instance Sing (xs :: [k]) where + SN :: Sing '[] + SC :: Sing x -> Sing xs -> Sing (x ': xs) + +instance SingI '[] where sing = SN +instance (SingI x, SingI xs) => SingI (x ': xs) where sing = SC sing sing + +{------------------------------------------------------------------------------- + General purpose type level functions +-------------------------------------------------------------------------------} + +type family Or (a :: Bool) (b :: Bool) where + Or 'True b = 'True + Or a 'True = 'True + Or _ _ = 'False + +type family Equal (x :: k) (y :: k) where + Equal x x = 'True + Equal x y = 'False + +type family Elem (x :: k) (xs :: [k]) where + Elem x '[] = 'False + Elem x (y ': ys) = Or (Equal x y) (Elem x ys) + +-- | Assert type-level predicate +-- +-- We cannot define this in terms of a more general @If@ construct, because +-- @ghc@'s type-level language has an undefined reduction order and so we get +-- no short-circuiting. +type family Assert (b :: Bool) (err :: ErrorMessage) :: Constraint where + Assert 'True err = () + Assert 'False err = TypeError err + +{------------------------------------------------------------------------------- + Decidable equality gives a decidable membership check +-------------------------------------------------------------------------------} + +data IsElem (x :: k) (xs :: [k]) where + IsElem :: Elem x xs ~ 'True => IsElem x xs + +shiftIsElem :: IsElem x ys -> IsElem x (y ': ys) +shiftIsElem IsElem = IsElem + +checkIsElem :: + DecidableEquality k + => Sing (x :: k) -> Sing (xs :: [k]) -> Maybe (IsElem x xs) +checkIsElem _ SN = Nothing +checkIsElem x (SC y ys) = case decideEquality x y of + Just Refl -> Just IsElem + Nothing -> shiftIsElem <$> checkIsElem x ys + +{------------------------------------------------------------------------------- + Phantom type parameters +-------------------------------------------------------------------------------} + +-- | Functors with phantom arguments +class Phantom (f :: k -> Type) where + -- | Similar to 'Data.Functor.Contravariant.phantom', but without requiring + -- 'Functor' or 'Contravariant' + phantom :: forall a b. f a -> f b + +data Poly (f :: k -> Type) = Poly (forall (a :: k). f a) + +-- | Commute @Maybe@ and @forall@ +maybePoly :: Phantom f => Maybe (f a) -> Maybe (Poly f) +maybePoly = fmap (\v -> Poly (phantom v)) diff --git a/src/Debug/RecoverRTTI/Wrappers.hs b/src/Debug/RecoverRTTI/Wrappers.hs new file mode 100644 --- /dev/null +++ b/src/Debug/RecoverRTTI/Wrappers.hs @@ -0,0 +1,70 @@ +-- | Newtype wrappers +-- +-- For some types, we infer a "wrapped type" instead. It is important that +-- these wrappers are all /newtypes/ and not /datatypes, because when we have +-- a value @x :: a@ and a corresponding classifier @Classifier a@, we should be +-- able to @unsafeCoerce x@ to whatever type the classifier tells us. If we +-- don't use newtypes but datatypes here, then that would not be possible. +-- +-- We use these newtypes primarily so that we can give some custom type class +-- instances. In particular, this means that for example our inferred functions +-- have a show instance, even if they are simply shown as @@; this is +-- nonetheless stil useful, as it means that we can show /everything/, which is +-- kind of the point. +module Debug.RecoverRTTI.Wrappers ( + -- * Functions + SomeFun(..) + -- * Reference cells + , SomeSTRef(..) + , SomeMVar(..) + , SomeTVar(..) + ) where + +import Control.Concurrent.MVar (MVar) +import Control.Concurrent.STM (TVar) +import Data.STRef (STRef) +import GHC.Exts + +{------------------------------------------------------------------------------- + Functions +-------------------------------------------------------------------------------} + +-- | Functions +-- +-- We do not try to infer the domain or codomain of the function. +newtype SomeFun = SomeFun (Any -> Any) + +{------------------------------------------------------------------------------- + Reference cells + + We do not try to look inside these variables to figure out the type of their + elements; the show instance merely shows an address. +-------------------------------------------------------------------------------} + +newtype SomeSTRef = SomeSTRef (STRef Any Any) + deriving (Eq) + +newtype SomeMVar = SomeMVar (MVar Any) + deriving (Eq) + +newtype SomeTVar = SomeTVar (TVar Any) + deriving (Eq) + +{------------------------------------------------------------------------------- + Show instances + + Unfortunately reference cells are moved by GC, so we can't do much here; + showing the address of the variable isn't particularly helpful. +-------------------------------------------------------------------------------} + +instance Show SomeSTRef where + show _ = "" -- they look the same on the heap + +instance Show SomeMVar where + show _ = "" + +instance Show SomeTVar where + show _ = "" + +instance Show SomeFun where + show _ = "" diff --git a/tests/RecoverRttiTests.hs b/tests/RecoverRttiTests.hs new file mode 100644 --- /dev/null +++ b/tests/RecoverRttiTests.hs @@ -0,0 +1,17 @@ +module Main (main) where + +import Test.Tasty + +import qualified Test.RecoverRTTI.Sanity +import qualified Test.RecoverRTTI.Classify +import qualified Test.RecoverRTTI.Show + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "RecoverRttiTests" [ + Test.RecoverRTTI.Sanity.tests + , Test.RecoverRTTI.Classify.tests + , Test.RecoverRTTI.Show.tests + ] diff --git a/tests/Test/RecoverRTTI/Arbitrary.hs b/tests/Test/RecoverRTTI/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/Arbitrary.hs @@ -0,0 +1,603 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.RecoverRTTI.Arbitrary ( + ClassifiedGen(..) + , arbitraryClassifiedGen + -- * Example values of reference cells + , exampleIORef + , exampleSTRef + , exampleMVar + , exampleTVar + ) where + +import Control.Concurrent.MVar (newEmptyMVar) +import Control.Concurrent.STM (newTVarIO) +import Control.Monad +import Control.Monad.ST.Unsafe (unsafeSTToIO) +import Data.Bifunctor +import Data.IORef (newIORef) +import Data.Maybe (catMaybes) +import Data.SOP +import Data.SOP.Dict +import Data.STRef (newSTRef) +import Data.Tree (Tree) +import Data.Void +import GHC.Real +import System.IO.Unsafe (unsafePerformIO) +import Unsafe.Coerce (unsafeCoerce) + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS.Strict +import qualified Data.ByteString.Lazy as BS.Lazy +import qualified Data.ByteString.Short as BS.Short +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as Text.Strict +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Tree as Tree +import qualified Data.Vector as Vector + +import Test.QuickCheck hiding (classify, NonEmpty) + +import Debug.RecoverRTTI +import Debug.RecoverRTTI.Util +import Debug.RecoverRTTI.Util.TypeLevel + +import Test.RecoverRTTI.ConcreteClassifier +import Test.RecoverRTTI.Orphans () +import Test.RecoverRTTI.UserDefined + +{------------------------------------------------------------------------------- + Generic auxiliary +-------------------------------------------------------------------------------} + +newtype SizedGen a = SizedGen (Int -> Gen a) + deriving (Functor) + +runSized :: Int -> SizedGen a -> Gen a +runSized n (SizedGen gen) = gen n + +ignoreSize :: Gen a -> SizedGen a +ignoreSize gen = SizedGen $ \_sz -> gen + +{------------------------------------------------------------------------------- + Arbitrary instance +-------------------------------------------------------------------------------} + +-- | Quickcheck generator along with a classifier +data ClassifiedGen a where + ClassifiedGen :: + (Show a, Eq a) + => { -- | The classifier for the generator + genClassifier :: ConcreteClassifier a + + -- | The classified generator itself + -- + -- The size argument determines the maximum size of the /value/ + -- (as opposed to the maximum size of the /type/) + , classifiedGen :: SizedGen a + } + -> ClassifiedGen a + +canShowClassifiedGen :: ClassifiedGen a -> Dict Show a +canShowClassifiedGen ClassifiedGen{} = Dict + +canEqClassifiedGen :: ClassifiedGen a -> Dict Eq a +canEqClassifiedGen ClassifiedGen{} = Dict + +defaultClassifiedGen :: + (Arbitrary a, Show a, Eq a) + => ConcreteClassifier a + -> ClassifiedGen a +defaultClassifiedGen cc = ClassifiedGen cc $ ignoreSize arbitrary + +-- | Generated arbitrary classifier along with a generator for that value +-- +-- NOTE: The @sz@ parameter limits the size of the /type tree/ (i.e., the number +-- of recursive calls to arbitraryClassifiedGen), /not/ the size of the +-- generated /values/. +arbitraryClassifiedGen :: Int -> Gen (Some ClassifiedGen) +arbitraryClassifiedGen typSz + | typSz < 0 = error "arbitraryClassifiedGen: uhoh.. bug" + | typSz == 0 = elements leaves + | otherwise = oneof (elements leaves : catMaybes compound) + where + -- Leaves of the tree (values with no recursion) + -- + -- Since there are the leaves, we don't need to check the size + leaves :: [Some ClassifiedGen] + leaves = concat [ + -- Primitive types + [ Some $ defaultClassifiedGen CC_Bool + , Some $ defaultClassifiedGen CC_Char + , Some $ defaultClassifiedGen CC_Double + , Some $ defaultClassifiedGen CC_Float + , Some $ defaultClassifiedGen CC_Int + , Some $ defaultClassifiedGen CC_Int16 + , Some $ defaultClassifiedGen CC_Int8 + , Some $ defaultClassifiedGen CC_Int32 + , Some $ defaultClassifiedGen CC_Int64 + , Some $ defaultClassifiedGen CC_Integer + , Some $ defaultClassifiedGen CC_Ordering + , Some $ defaultClassifiedGen CC_Unit + , Some $ defaultClassifiedGen CC_Word + , Some $ defaultClassifiedGen CC_Word8 + , Some $ defaultClassifiedGen CC_Word16 + , Some $ defaultClassifiedGen CC_Word32 + , Some $ defaultClassifiedGen CC_Word64 + ] + + -- Strings + -- + -- Avoid generating the empty string (recognized as @[Void]@) + , let mapList :: Arbitrary a => Int -> ([a] -> b) -> SizedGen b + mapList minSize f = SizedGen $ \valSz -> do + n <- choose (minSize, max minSize valSz) -- maybe valSz == 0 + f <$> vector n + in [ + Some $ ClassifiedGen CC_String (mapList 1 id) + , Some $ ClassifiedGen CC_BS_Strict (mapList 0 BS.Strict.pack) + , Some $ ClassifiedGen CC_BS_Lazy (mapList 0 BS.Lazy.pack) + , Some $ ClassifiedGen CC_BS_Short (mapList 0 BS.Short.pack) + , Some $ ClassifiedGen CC_Text_Strict (mapList 0 Text.Strict.pack) + , Some $ ClassifiedGen CC_Text_Lazy (mapList 0 Text.Lazy.pack) + ] + + -- Aeson + , [ Some $ ClassifiedGen CC_Value arbitraryAesonValue ] + + -- Reference cells + , [ Some $ ClassifiedGen CC_STRef (ignoreSize $ pure exampleSTRef) + , Some $ ClassifiedGen CC_STRef (ignoreSize $ pure exampleIORef) + , Some $ ClassifiedGen CC_MVar (ignoreSize $ pure exampleMVar) + , Some $ ClassifiedGen CC_TVar (ignoreSize $ pure exampleTVar) + ] + + -- Functions + -- + -- For functions we don't currently try to be clever and /generate/ + -- functions. Instead, we just try a few different categories. + , map (\f -> Some $ ClassifiedGen CC_Fun (ignoreSize $ pure f)) [ + -- Parametrically polymorphic function + unsafeCoerce (id :: Int -> Int) + , unsafeCoerce (const :: Int -> Bool -> Int) + -- Ad-hoc polymorphic function + , unsafeCoerce (negate :: Int -> Int) + , unsafeCoerce ((+) :: Int -> Int -> Int) + -- Partial application + , unsafeCoerce (const 1 :: Bool -> Int) + , unsafeCoerce ((+) 1 :: Int -> Int) + ] + ] + + -- Compound + -- + -- These are only used if @sz > 0@. + compound :: [Maybe (Gen (Some ClassifiedGen))] + compound = [ + -- Lists + -- + -- We have to be careful not to generate @[Char]@, because this is + -- inferred as @String@ + guard (typSz >= 1) >> (return $ do + Some a <- arbitraryClassifiedGen (typSz - 1) + genMaybeF + (\case FJust CC_Char -> CC_String + c -> CC_List c) + (return []) + (\(SizedGen gen) -> SizedGen $ \valSz -> do + -- Pick number of list elements (don't generate empty list) + n <- choose (1, 5) + + -- Then divide total size of each list element + vectorOf n (gen (valSz `div` n)) + ) + a + ) + + -- Maybe + , guard (typSz >= 1) >> (return $ do + Some a <- arbitraryClassifiedGen (typSz - 1) + genMaybeF CC_Maybe (return Nothing) (fmap Just) a + ) + + -- Either + , guard (typSz >= 2) >> (return $ do + Some a <- arbitraryClassifiedGen (typSz `div` 2) + Some b <- arbitraryClassifiedGen (typSz `div` 2) + genEitherF CC_Either (fmap Left) (fmap Right) a b + ) + + -- Ratio + , guard (typSz >= 1) >> (return $ do + Some a <- arbitraryClassifiedGen (typSz `div` 2) + genF + CC_Ratio + (\(SizedGen gen) -> SizedGen $ \sz -> + (:%) <$> gen (sz `div` 2) <*> gen (sz `div` 2) + ) + a + ) + + -- Set + -- For set we must pick an ordered type, so we just pick Int + , return (do + genMaybeF + CC_Set + (return Set.empty) + -- Same strategy as for lists + (\(SizedGen gen) -> SizedGen $ \valSz -> do + n <- choose (1, 5) + Set.fromList <$> vectorOf n (gen (valSz `div` n)) + ) + (defaultClassifiedGen CC_Int) + ) + + -- Map + -- Pick Int for the keys, but randomly for the values + , guard (typSz >= 1) >> (return $ do + Some b <- arbitraryClassifiedGen (typSz - 1) + genMaybePairF + CC_Map + (return Map.empty) + (\(SizedGen genX) (SizedGen genY) -> SizedGen $ \valSz -> do + n <- choose (1, 5) + Map.fromList <$> vectorOf n ( + (,) <$> genX (valSz `div` n `div` 2) + <*> genY (valSz `div` n `div` 2) + ) + ) + (defaultClassifiedGen CC_Int) + b + ) + + -- IntSet + , return $ return $ Some (defaultClassifiedGen CC_IntSet) + + -- IntMap + , guard (typSz >= 1) >> (return $ do + Some b <- arbitraryClassifiedGen (typSz - 1) + genMaybeF + CC_IntMap + (return IntMap.empty) + (\(SizedGen genY) -> SizedGen $ \valSz -> do + n <- choose (1, 5) + IntMap.fromList <$> vectorOf n ( + (,) <$> arbitrary + <*> genY (valSz `div` n) + ) + ) + b + ) + + -- Sequence + , guard (typSz >= 1) >> (return $ do + Some a <- arbitraryClassifiedGen (typSz - 1) + genMaybeF + CC_Sequence + (return Seq.empty) + (\(SizedGen genX) -> SizedGen $ \valSz -> do + n <- choose (1, 5) + Seq.fromList <$> vectorOf n (genX (valSz `div` n)) + ) + a + ) + + -- Tree + , guard (typSz >= 1) >> (return $ do + Some a <- arbitraryClassifiedGen (typSz - 1) + genF + CC_Tree + (\(SizedGen genX) -> SizedGen $ \valSz -> do + n <- choose (1, 5) + mkSomeTree <$> vectorOf n (genX (valSz `div` n)) + ) + a + ) + + -- + -- User-defined + -- + + , guard (typSz >= 1) >> (return $ do + Some a <- arbitraryClassifiedGen (typSz - 1) + genMaybeF + CC_User_NonRec + (NR1 <$> arbitrary) + (\gen -> SizedGen $ \valSz -> + NR2 <$> runSized valSz gen <*> arbitrary + ) + a + ) + + , guard (typSz >= 1) >> (return $ do + Some a <- arbitraryClassifiedGen (typSz - 1) + genMaybeF + CC_User_Rec + (return RNil) + (\gen -> SizedGen $ \valSz -> do + -- Similar strategy as for lists + n <- choose (1, 5) + recursiveFromList <$> vectorOf n (runSized (valSz `div` n) gen) + ) + a + ) + + , return $ do + return $ Some $ ClassifiedGen (CC_User_Unlifted (FJust CC_Unit)) $ SizedGen $ \_ -> + return exampleContainsUnlifted + + -- Tuples + , guard (typSz >= 2) >> (return $ + arbitraryTuple typSz $ \np -> + case ( all_NP (hmap canShowClassifiedGen np) + , all_NP (hmap canEqClassifiedGen np) + ) of + (Dict, Dict) -> + return . Some $ ClassifiedGen { + genClassifier = + CC_Tuple (ConcreteClassifiers (hmap genClassifier np)) + , classifiedGen = SizedGen $ \valSz -> do + let valSz' = valSz `div` lengthSList np + tupleFromNP <$> + hsequence(hmap (runSized valSz' . classifiedGen) np) + } + ) + ] + + genMaybeF :: + ( forall x. Show x => Show (f x) + , forall x. Eq x => Eq (f x) + ) + => (forall x. MaybeF ConcreteClassifier x -> ConcreteClassifier (f x)) + -> Gen (f Void) + -> (SizedGen a -> SizedGen (f a)) + -> ClassifiedGen a -> Gen (Some ClassifiedGen) + genMaybeF cc genNothing genJust (ClassifiedGen cA genA) = + elements [ + Some $ ClassifiedGen (cc FNothing) (ignoreSize $ genNothing) + , Some $ ClassifiedGen (cc (FJust cA)) (genJust genA) + ] + + genEitherF :: + ( forall x y. (Show x, Show y) => Show (f x y) + , forall x y. (Eq x, Eq y) => Eq (f x y) + ) + => (forall x y. EitherF ConcreteClassifier x y -> ConcreteClassifier (f x y)) + -> (SizedGen a -> SizedGen (f a Void)) + -> (SizedGen b -> SizedGen (f Void b)) + -> ClassifiedGen a + -> ClassifiedGen b + -> Gen (Some ClassifiedGen) + genEitherF cc genLeft genRight (ClassifiedGen cA genA) (ClassifiedGen cB genB) = + elements [ + Some $ ClassifiedGen (cc (FLeft cA)) (genLeft genA) + , Some $ ClassifiedGen (cc (FRight cB)) (genRight genB) + ] + + genMaybePairF :: + ( forall x y. (Show x, Show y) => Show (f x y) + , forall x y. (Eq x, Eq y) => Eq (f x y) + ) + => (forall x y. MaybePairF ConcreteClassifier x y -> ConcreteClassifier (f x y)) + -> Gen (f Void Void) + -> (SizedGen a -> SizedGen b -> SizedGen (f a b)) + -> ClassifiedGen a -> ClassifiedGen b -> Gen (Some ClassifiedGen) + genMaybePairF cc genNothing genJust (ClassifiedGen cA genA) (ClassifiedGen cB genB) = + elements [ + Some $ ClassifiedGen (cc FNothingPair) (ignoreSize $ genNothing) + , Some $ ClassifiedGen (cc (FJustPair cA cB)) (genJust genA genB) + ] + + genF :: + ( forall x. Show x => Show (f x) + , forall x. Eq x => Eq (f x) + ) + => (forall x. ConcreteClassifier x -> ConcreteClassifier (f x)) + -> (SizedGen a -> SizedGen (f a)) + -> ClassifiedGen a -> Gen (Some ClassifiedGen) + genF cc gen (ClassifiedGen cA genA) = return $ + Some $ ClassifiedGen (cc cA) (gen genA) + + -- We check that we cover all cases of 'Classifier' rather than + -- 'ConcreteClassifier': it is important that we generate test cases for + -- everything we classify in the main library. + _checkAllCases :: Classifier a -> () + _checkAllCases = \case + -- Primitive types + + C_Bool -> () + C_Char -> () + C_Double -> () + C_Float -> () + C_Int -> () + C_Int16 -> () + C_Int8 -> () + C_Int32 -> () + C_Int64 -> () + C_Integer -> () + C_Ordering -> () + C_Unit -> () + C_Word -> () + C_Word8 -> () + C_Word16 -> () + C_Word32 -> () + C_Word64 -> () + + -- String types + + C_String -> () + C_BS_Strict -> () + C_BS_Lazy -> () + C_BS_Short -> () + C_Text_Strict -> () + C_Text_Lazy -> () + + -- Aeson + + C_Value -> () + + -- Compound + + C_Maybe{} -> () + C_Either{} -> () + C_List{} -> () + C_Ratio{} -> () + C_Set{} -> () + C_Map{} -> () + C_IntSet{} -> () + C_IntMap{} -> () + C_Tuple{} -> () + C_Sequence{} -> () + C_Tree{} -> () + + -- Reference cells + + C_STRef -> () + C_TVar -> () + C_MVar -> () + + -- Functions + + C_Fun -> () + + -- User-defined + + C_Custom{} -> () + +-- | Generate arbitrary tuple size +arbitraryTuple :: forall r. + Int -- ^ Maximum type size (should be at least 2) + -> (forall xs. + (SListI xs, IsValidSize (Length xs)) + => NP ClassifiedGen xs -> Gen r + ) + -> Gen r +arbitraryTuple = \typSz k -> do + tupleSz <- choose (2, min typSz 62) + let typSz' = typSz `div` tupleSz + case toValidSize tupleSz of + Nothing -> + error "arbitraryTuple: impossible, this is a valid tuple size" + Just (Some valid@(ValidSize n _)) -> + go typSz' n $ \(np :: NP ClassifiedGen xs) -> + case liftValidSize (valid :: ValidSize (Length xs)) + of Dict -> k np + where + go :: Int + -> Sing (n :: Nat) + -> (forall xs. + (SListI xs, Length xs ~ n) + => NP ClassifiedGen xs -> Gen r + ) + -> Gen r + go _ SZ k = k Nil + go typSz' (SS n) k = do + Some c <- arbitraryClassifiedGen typSz' + go typSz' n $ \cs -> k (c :* cs) + +instance Arbitrary (Some Value) where + arbitrary = sized $ \sz -> do + -- @sz@ will range from 0..100, but we don't want to generate types that + -- large + Some (ClassifiedGen cc gen) <- arbitraryClassifiedGen (sz `div` 10) + + -- For the values however we want to be able to generate larger trees + Some . Value cc <$> runSized sz gen + +{------------------------------------------------------------------------------- + Auxiliary tree functions +-------------------------------------------------------------------------------} + +mkSomeTree :: [a] -> Tree a +mkSomeTree [] = error "mkSomeTree: empty" +mkSomeTree [x] = Tree.Node x [] +mkSomeTree [x, y] = Tree.Node x [Tree.Node y []] +mkSomeTree (x : xs) = + let (left, right) = split xs + in Tree.Node x [mkSomeTree left, mkSomeTree right] + +-- | Split list into halves +-- +-- If the input has at least two elements, neither list will be empty +-- +-- > split "abcde" == ("ace","bd") +split :: [a] -> ([a], [a]) +split [] = ([], []) +split (x:xs) = first (x:) $ splot xs + +-- | Auxiliary to 'split' +splot :: [a] -> ([a], [a]) +splot [] = ([], []) +splot (x:xs) = second (x:) $ split xs + +{------------------------------------------------------------------------------- + Auxiliary Aeson +-------------------------------------------------------------------------------} + +arbitraryAesonValue :: SizedGen Aeson.Value +arbitraryAesonValue = SizedGen $ go + where + go :: Int -> Gen Aeson.Value + go 0 = oneof nonRecursive + go sz = oneof (nonRecursive ++ recursive sz) + + nonRecursive :: [Gen Aeson.Value] + nonRecursive = [ + Aeson.String . Text.Strict.pack <$> arbitrary + , Aeson.Number . fromInteger <$> arbitrary + , Aeson.Bool <$> arbitrary + , return Aeson.Null + ] + + recursive :: Int -> [Gen Aeson.Value] + recursive sz = [ + do n <- choose (0, 5) + Aeson.Array . Vector.fromList <$> replicateM n (go (sz `div` n)) + , do n <- choose (0, 5) + Aeson.object <$> replicateM n ( + (Aeson..=) + <$> fieldName + <*> go (sz `div` n) + ) + ] + + -- We're not interested in testing crazy values + fieldName :: Gen Text.Strict.Text + fieldName = elements ["a", "b", "c"] + +{------------------------------------------------------------------------------- + Some global variables, which we use only as input to the tests +-------------------------------------------------------------------------------} + +exampleIORef :: SomeSTRef +{-# NOINLINE exampleIORef #-} +exampleIORef = unsafePerformIO $ + -- IORef is indistinguishable from STRef on the heap + unsafeCoerce <$> newIORef (unsafeCoerce ()) + +exampleSTRef :: SomeSTRef +exampleSTRef = unsafePerformIO $ unsafeSTToIO $ + unsafeCoerce <$> newSTRef (unsafeCoerce ()) + +exampleMVar :: SomeMVar +{-# NOINLINE exampleMVar #-} +exampleMVar = unsafePerformIO $ + SomeMVar <$> newEmptyMVar + +exampleTVar :: SomeTVar +{-# NOINLINE exampleTVar #-} +exampleTVar = unsafePerformIO $ + SomeTVar <$> newTVarIO (unsafeCoerce ()) diff --git a/tests/Test/RecoverRTTI/Classify.hs b/tests/Test/RecoverRTTI/Classify.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/Classify.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Verify we infer the right classifier +module Test.RecoverRTTI.Classify (tests) where + +import Control.Monad.Except +import Data.Ratio +import Data.SOP +import Data.Type.Equality + +import qualified Data.Aeson as Aeson +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Tree as Tree + +import Test.Tasty +import Test.Tasty.QuickCheck hiding (classify, NonEmpty) + +import Debug.RecoverRTTI +import Debug.RecoverRTTI.Util + +import Test.RecoverRTTI.Arbitrary +import Test.RecoverRTTI.ConcreteClassifier +import Test.RecoverRTTI.Orphans () +import Test.RecoverRTTI.Staged +import Test.RecoverRTTI.UserDefined + +tests :: TestTree +tests = testGroup "Test.RecoverRTTI.Classify" [ + testProperty "constants" prop_constants + , testProperty "arbitrary" prop_arbitrary + ] + +-- | Test using manually specified examples +-- +-- For " normal " code it doesn't matter if something is generated or not, +-- but their on-heap representation may be different, and this may effect the +-- RTTI recovery. +prop_constants :: Property +prop_constants = withMaxSuccess 1 $ conjoin [ + -- Primitive types + + compareClassifier $ Value CC_Bool True + , compareClassifier $ Value CC_Bool False + , compareClassifier $ Value CC_Char 'a' + , compareClassifier $ Value CC_Double 1.25 + , compareClassifier $ Value CC_Float 1.25 + , compareClassifier $ Value CC_Int 1234 + , compareClassifier $ Value CC_Int (-1234) + , compareClassifier $ Value CC_Int8 123 + , compareClassifier $ Value CC_Int16 1234 + , compareClassifier $ Value CC_Int32 1234 + , compareClassifier $ Value CC_Int64 1234 + , compareClassifier $ Value CC_Integer 1234 + , compareClassifier $ Value CC_Integer (succ (fromIntegral (maxBound :: Int))) + , compareClassifier $ Value CC_Integer (pred (fromIntegral (minBound :: Int))) + , compareClassifier $ Value CC_Ordering LT + , compareClassifier $ Value CC_Ordering GT + , compareClassifier $ Value CC_Ordering EQ + , compareClassifier $ Value CC_Unit () + , compareClassifier $ Value CC_Word 1234 + , compareClassifier $ Value CC_Word8 123 + , compareClassifier $ Value CC_Word16 134 + , compareClassifier $ Value CC_Word32 1234 + , compareClassifier $ Value CC_Word64 1234 + + -- String types + -- + -- We skip the empty string, because we infer that as @CC_List Empty@ + + , compareClassifier $ Value CC_String "abcdefg" + , compareClassifier $ Value CC_BS_Strict "" + , compareClassifier $ Value CC_BS_Strict "abcdefg" + , compareClassifier $ Value CC_BS_Lazy "" + , compareClassifier $ Value CC_BS_Lazy "abcdefg" + , compareClassifier $ Value CC_BS_Short "" + , compareClassifier $ Value CC_BS_Short "abcdefg" + , compareClassifier $ Value CC_Text_Strict "" + , compareClassifier $ Value CC_Text_Strict "abcdefg" + , compareClassifier $ Value CC_Text_Lazy "" + , compareClassifier $ Value CC_Text_Lazy "abcdefg" + + -- Aeson + + , compareClassifier $ Value CC_Value (Aeson.object [("x" Aeson..= True)]) + + -- Compound + + , compareClassifier $ Value (CC_Maybe FNothing) Nothing + , compareClassifier $ Value (CC_Maybe (FJust CC_Int)) (Just 3) + + , compareClassifier $ Value (CC_Either (FLeft CC_Int)) (Left 3) + , compareClassifier $ Value (CC_Either (FRight CC_Bool)) (Right True) + + , compareClassifier $ Value (CC_List FNothing) [] + , compareClassifier $ Value (CC_List (FJust CC_Int)) [1, 2, 3] + + , compareClassifier $ Value (CC_Tuple (ConcreteClassifiers (CC_Int :* CC_Char :* Nil))) (WrappedTuple (4, 'a')) + , compareClassifier $ Value (CC_Tuple (ConcreteClassifiers (CC_Int :* CC_Char :* CC_Bool :* Nil))) (WrappedTuple (4, 'a', True)) + + , compareClassifier $ Value (CC_Ratio CC_Integer) (1 % 2) + + , compareClassifier $ Value (CC_Set FNothing) Set.empty + , compareClassifier $ Value (CC_Set (FJust CC_Int)) (Set.fromList [1, 2, 3] ) + + , compareClassifier $ Value (CC_Map FNothingPair) Map.empty + , compareClassifier $ Value (CC_Map (FJustPair CC_Int CC_Char)) (Map.fromList [(1, 'a'), (2, 'b')]) + + , compareClassifier $ Value CC_IntSet IntSet.empty + , compareClassifier $ Value CC_IntSet (IntSet.fromList [1, 2, 3]) + + , compareClassifier $ Value (CC_IntMap FNothing) IntMap.empty + , compareClassifier $ Value (CC_IntMap (FJust CC_Char)) (IntMap.fromList [(1, 'a'), (2, 'b')]) + + , compareClassifier $ Value (CC_Sequence FNothing) Seq.empty + , compareClassifier $ Value (CC_Sequence (FJust CC_Int)) (Seq.fromList [1, 2, 3]) + + , compareClassifier $ Value (CC_Tree CC_Int) (Tree.Node 1 []) + + -- Reference cells + + , compareClassifier $ Value CC_STRef exampleIORef + , compareClassifier $ Value CC_STRef exampleSTRef + , compareClassifier $ Value CC_MVar exampleMVar + , compareClassifier $ Value CC_TVar exampleTVar + + -- Functions + + , compareClassifier $ Value CC_Fun (SomeFun id) + + -- User defined + + , compareClassifier $ Value (CC_User_NonRec FNothing) (NR1 1234) + , compareClassifier $ Value (CC_User_NonRec (FJust CC_Char)) (NR2 'a' True) + , compareClassifier $ Value (CC_User_Rec FNothing) RNil + , compareClassifier $ Value (CC_User_Rec (FJust CC_Char)) (RCons 'a' RNil) + , compareClassifier $ Value (CC_User_Unlifted (FJust CC_Unit)) exampleContainsUnlifted + ] + where + _checkAllCases :: ConcreteClassifier a -> () + _checkAllCases = \case + -- Primitive types + + CC_Bool -> () + CC_Char -> () + CC_Double -> () + CC_Float -> () + CC_Int -> () + CC_Int8 -> () + CC_Int16 -> () + CC_Int32 -> () + CC_Int64 -> () + CC_Integer -> () + CC_Ordering -> () + CC_Unit -> () + CC_Word -> () + CC_Word8 -> () + CC_Word16 -> () + CC_Word32 -> () + CC_Word64 -> () + + -- String types + + CC_String -> () + CC_BS_Strict -> () + CC_BS_Lazy -> () + CC_BS_Short -> () + CC_Text_Strict -> () + CC_Text_Lazy -> () + + -- Aeson + + CC_Value -> () + + -- Compound + + CC_Maybe{} -> () + CC_Either{} -> () + CC_List{} -> () + CC_Ratio{} -> () + CC_Set{} -> () + CC_Map{} -> () + CC_IntSet{} -> () + CC_IntMap{} -> () + CC_Sequence{} -> () + CC_Tree{} -> () + CC_Tuple{} -> () + + -- Functions + + CC_Fun{} -> () + + -- Reference cells + + CC_STRef -> () + CC_TVar -> () + CC_MVar -> () + + -- User-defined + + CC_User_NonRec{} -> () + CC_User_Rec{} -> () + CC_User_Unlifted{} -> () + +-- | Test using arbitrary values +prop_arbitrary :: Some Value -> Property +prop_arbitrary (Some v) = compareClassifier v + +-- | Compare given to inferred classifier +-- +-- The tests in this module differ only in how the produce the 'Value's. +compareClassifier :: Value a -> Property +compareClassifier = \(Value cc x) -> + counterexample ("Generated classifier: " ++ show cc) + $ case runExcept $ classifyThenReclassify x of + Left err -> + counterexample ("Failed to reclassify. Error: " ++ err) + $ property False + Right (Reclassified cc' f) -> + case sameConcreteClassifier cc cc' of + Nothing -> + counterexample ("Inferred different classifier: " ++ show cc') + $ property False + Just Refl -> + x === f x diff --git a/tests/Test/RecoverRTTI/ConcreteClassifier.hs b/tests/Test/RecoverRTTI/ConcreteClassifier.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/ConcreteClassifier.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.RecoverRTTI.ConcreteClassifier ( + -- * Concrete classifier + ConcreteClassifier(..) + , sameConcreteClassifier + , ConcreteClassifiers(..) + , classifierSize + -- * Values + , Value(..) + ) where + +import Data.Int +import Data.IntMap (IntMap) +import Data.IntSet (IntSet) +import Data.Kind +import Data.Map (Map) +import Data.Ratio +import Data.Sequence (Seq) +import Data.Set (Set) +import Data.SOP +import Data.SOP.Dict +import Data.Tree (Tree) +import Data.Type.Equality +import Data.Word + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS.Strict +import qualified Data.ByteString.Lazy as BS.Lazy +import qualified Data.ByteString.Short as BS.Short +import qualified Data.Text as Text.Strict +import qualified Data.Text.Lazy as Text.Lazy + +import Debug.RecoverRTTI +import Debug.RecoverRTTI.Util +import Debug.RecoverRTTI.Util.TypeLevel + +import Test.RecoverRTTI.UserDefined + +{------------------------------------------------------------------------------- + Concrete classifier + + The difference between the " concrete " classifier and the 'Classifier' from + the main library is that the former has explicit cases for user-defined types, + and the latter doesn't (merely classifying them as 'UserDefined'). + + In "Test.RecoverRRTI.Staged" we show that we can do staged inference, + using 'classify' repeatedly to recover /all/ (concrete) type information + from the type information returned by 'classify' (/if/ we have full + information about which user-defined types we're interested in). +-------------------------------------------------------------------------------} + +-- | Like 'Classifier', but with no guess-work and concrete types +data ConcreteClassifier (a :: Type) :: Type where + -- Primitive types + + CC_Bool :: ConcreteClassifier Bool + CC_Char :: ConcreteClassifier Char + CC_Double :: ConcreteClassifier Double + CC_Float :: ConcreteClassifier Float + CC_Int :: ConcreteClassifier Int + CC_Int8 :: ConcreteClassifier Int8 + CC_Int16 :: ConcreteClassifier Int16 + CC_Int32 :: ConcreteClassifier Int32 + CC_Int64 :: ConcreteClassifier Int64 + CC_Integer :: ConcreteClassifier Integer + CC_Ordering :: ConcreteClassifier Ordering + CC_Unit :: ConcreteClassifier () + CC_Word :: ConcreteClassifier Word + CC_Word8 :: ConcreteClassifier Word8 + CC_Word16 :: ConcreteClassifier Word16 + CC_Word32 :: ConcreteClassifier Word32 + CC_Word64 :: ConcreteClassifier Word64 + + -- Text types + + CC_String :: ConcreteClassifier String + CC_BS_Strict :: ConcreteClassifier BS.Strict.ByteString + CC_BS_Lazy :: ConcreteClassifier BS.Lazy.ByteString + CC_BS_Short :: ConcreteClassifier BS.Short.ShortByteString + CC_Text_Strict :: ConcreteClassifier Text.Strict.Text + CC_Text_Lazy :: ConcreteClassifier Text.Lazy.Text + + -- Aeson + + CC_Value :: ConcreteClassifier Aeson.Value + + -- Compound + + CC_Maybe :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Maybe a) + CC_Either :: EitherF ConcreteClassifier a b -> ConcreteClassifier (Either a b) + CC_List :: MaybeF ConcreteClassifier a -> ConcreteClassifier [a] + CC_Ratio :: ConcreteClassifier a -> ConcreteClassifier (Ratio a) + CC_Set :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Set a) + CC_Map :: MaybePairF ConcreteClassifier a b -> ConcreteClassifier (Map a b) + CC_IntSet :: ConcreteClassifier IntSet + CC_IntMap :: MaybeF ConcreteClassifier a -> ConcreteClassifier (IntMap a) + CC_Sequence :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Seq a) + CC_Tree :: ConcreteClassifier a -> ConcreteClassifier (Tree a) + + CC_Tuple :: + (SListI xs, IsValidSize (Length xs)) + => ConcreteClassifiers xs -> ConcreteClassifier (WrappedTuple xs) + + -- Functions + + CC_Fun :: ConcreteClassifier SomeFun + + -- Reference cells + + CC_STRef :: ConcreteClassifier SomeSTRef + CC_TVar :: ConcreteClassifier SomeTVar + CC_MVar :: ConcreteClassifier SomeMVar + + -- User-defined + + CC_User_NonRec :: MaybeF ConcreteClassifier a -> ConcreteClassifier (NonRecursive a) + CC_User_Rec :: MaybeF ConcreteClassifier a -> ConcreteClassifier (Recursive a) + CC_User_Unlifted :: MaybeF ConcreteClassifier a -> ConcreteClassifier (ContainsUnlifted a) + +newtype ConcreteClassifiers xs = ConcreteClassifiers (NP ConcreteClassifier xs) + +deriving instance Show (ConcreteClassifier a) +deriving instance Show (MaybeF ConcreteClassifier a) +deriving instance Show (EitherF ConcreteClassifier a b) +deriving instance Show (MaybePairF ConcreteClassifier a b) + +instance SListI xs => Show (ConcreteClassifiers xs) where + show (ConcreteClassifiers xs) = go (hpure Dict) + where + go :: NP (Dict (Compose Show ConcreteClassifier)) xs -> String + go dicts = + case all_NP dicts of + Dict -> "(" ++ show xs ++ ")" + +{------------------------------------------------------------------------------- + Size of the classifier + + Mostly used for sanity checking the generator +-------------------------------------------------------------------------------} + +classifierSize :: ConcreteClassifier a -> Int +classifierSize = go + where + go :: ConcreteClassifier a -> Int + + -- Primitive types + go CC_Bool = 1 + go CC_Char = 1 + go CC_Double = 1 + go CC_Float = 1 + go CC_Int = 1 + go CC_Int8 = 1 + go CC_Int16 = 1 + go CC_Int32 = 1 + go CC_Int64 = 1 + go CC_Integer = 1 + go CC_Ordering = 1 + go CC_Unit = 1 + go CC_Word = 1 + go CC_Word8 = 1 + go CC_Word16 = 1 + go CC_Word32 = 1 + go CC_Word64 = 1 + + -- Text types + go CC_String = 1 + go CC_BS_Strict = 1 + go CC_BS_Lazy = 1 + go CC_BS_Short = 1 + go CC_Text_Strict = 1 + go CC_Text_Lazy = 1 + + -- Aeson + go CC_Value = 1 + + -- Compound + + go (CC_Maybe c) = 1 + goMaybeF c + go (CC_Either c) = 1 + goEitherF c + go (CC_List c) = 1 + goMaybeF c + go (CC_Ratio c) = 1 + go c + go (CC_Set c) = 1 + goMaybeF c + go (CC_Map c) = 1 + goMaybePairF c + go CC_IntSet = 1 + go (CC_IntMap c) = 1 + goMaybeF c + go (CC_Sequence c) = 1 + goMaybeF c + go (CC_Tree c) = 1 + go c + + go (CC_Tuple (ConcreteClassifiers cs)) = + 1 + sum (hcollapse (hmap (K . go) cs)) + + -- Functions + go CC_Fun = 1 + + -- Reference cells + go CC_STRef = 1 + go CC_TVar = 1 + go CC_MVar = 1 + + -- User-defined + go (CC_User_NonRec c) = 1 + goMaybeF c + go (CC_User_Rec c) = 1 + goMaybeF c + go (CC_User_Unlifted c) = 1 + goMaybeF c + + goMaybeF :: MaybeF ConcreteClassifier a -> Int + goMaybeF FNothing = 0 + goMaybeF (FJust c) = go c + + goEitherF :: EitherF ConcreteClassifier a b -> Int + goEitherF (FLeft c) = go c + goEitherF (FRight c) = go c + + goMaybePairF :: MaybePairF ConcreteClassifier a b -> Int + goMaybePairF FNothingPair = 0 + goMaybePairF (FJustPair c c') = go c + go c' + +{------------------------------------------------------------------------------- + Values +-------------------------------------------------------------------------------} + +-- | Like 'Classified', but using 'ConcreteClassifier' +-- +-- For convenience, we also include some constraints here, even though they +-- are in fact derivable from the classifier +data Value a where + Value :: (Show a, Eq a) => ConcreteClassifier a -> a -> Value a + +deriving instance Show (Value a) +deriving instance Show (Some Value) + +{------------------------------------------------------------------------------- + Equality +-------------------------------------------------------------------------------} + +-- | Check that two classifiers are the same +-- +-- If they are the same, additionally return a proof that that means the +-- /types/ they classify must be equal (note that equality on the classifiers +-- is strictly stronger than equality on the types: for example, non-empty +-- and empty lists have different classifiers, but classify the same type). +sameConcreteClassifier :: + ConcreteClassifier a + -> ConcreteClassifier b + -> Maybe (a :~: b) +sameConcreteClassifier = go + where + go :: ConcreteClassifier a -> ConcreteClassifier b -> Maybe (a :~: b) + go CC_Bool CC_Bool = Just Refl + go CC_Char CC_Char = Just Refl + go CC_Double CC_Double = Just Refl + go CC_Float CC_Float = Just Refl + go CC_Int CC_Int = Just Refl + go CC_Int8 CC_Int8 = Just Refl + go CC_Int16 CC_Int16 = Just Refl + go CC_Int32 CC_Int32 = Just Refl + go CC_Int64 CC_Int64 = Just Refl + go CC_Integer CC_Integer = Just Refl + go CC_Ordering CC_Ordering = Just Refl + go CC_Unit CC_Unit = Just Refl + go CC_Word CC_Word = Just Refl + go CC_Word8 CC_Word8 = Just Refl + go CC_Word16 CC_Word16 = Just Refl + go CC_Word32 CC_Word32 = Just Refl + go CC_Word64 CC_Word64 = Just Refl + + -- String types + + go CC_String CC_String = Just Refl + go CC_BS_Strict CC_BS_Strict = Just Refl + go CC_BS_Lazy CC_BS_Lazy = Just Refl + go CC_BS_Short CC_BS_Short = Just Refl + go CC_Text_Strict CC_Text_Strict = Just Refl + go CC_Text_Lazy CC_Text_Lazy = Just Refl + + -- Aeson + + go CC_Value CC_Value = Just Refl + + -- Compound + + go (CC_Maybe c) (CC_Maybe c') = goMaybeF c c' + go (CC_Either c) (CC_Either c') = goEitherF c c' + go (CC_List c) (CC_List c') = goMaybeF c c' + go (CC_Ratio c) (CC_Ratio c') = goF c c' + go (CC_Set c) (CC_Set c') = goMaybeF c c' + go (CC_Map c) (CC_Map c') = goMaybePairF c c' + go CC_IntSet CC_IntSet = Just Refl + go (CC_IntMap c) (CC_IntMap c') = goMaybeF c c' + go (CC_Sequence c) (CC_Sequence c') = goMaybeF c c' + go (CC_Tree c) (CC_Tree c') = goF c c' + + go (CC_Tuple (ConcreteClassifiers cs)) + (CC_Tuple (ConcreteClassifiers cs')) = (\Refl -> Refl) <$> goList cs cs' + + -- Reference cells + + go CC_STRef CC_STRef = Just Refl + go CC_TVar CC_TVar = Just Refl + go CC_MVar CC_MVar = Just Refl + + -- Functions + + go CC_Fun CC_Fun = Just Refl + + -- User-defined + + go (CC_User_NonRec c) (CC_User_NonRec c') = goMaybeF c c' + go (CC_User_Rec c) (CC_User_Rec c') = goMaybeF c c' + go (CC_User_Unlifted c) (CC_User_Unlifted c') = goMaybeF c c' + + -- Otherwise, not equal + + go _ _ = Nothing + + goMaybeF :: + MaybeF ConcreteClassifier x + -> MaybeF ConcreteClassifier x' + -> Maybe (f x :~: f x') + goMaybeF FNothing FNothing = Just Refl + goMaybeF (FJust x) (FJust x') = (\Refl -> Refl) <$> go x x' + goMaybeF _ _ = Nothing + + goEitherF :: + EitherF ConcreteClassifier x y + -> EitherF ConcreteClassifier x' y' + -> Maybe (f x y :~: f x' y') + goEitherF (FLeft x) (FLeft x') = (\Refl -> Refl) <$> go x x' + goEitherF (FRight y) (FRight y') = (\Refl -> Refl) <$> go y y' + goEitherF (FLeft _) (FRight _ ) = Nothing + goEitherF (FRight _) (FLeft _ ) = Nothing + + goF :: + ConcreteClassifier x + -> ConcreteClassifier x' + -> Maybe (f x :~: f x') + goF x x' = (\Refl -> Refl) <$> go x x' + + goMaybePairF :: + MaybePairF ConcreteClassifier x y + -> MaybePairF ConcreteClassifier x' y' + -> Maybe (f x y :~: f x' y') + goMaybePairF FNothingPair FNothingPair = Just Refl + goMaybePairF (FJustPair x y) (FJustPair x' y') = (\Refl Refl -> Refl) <$> go x x' <*> go y y' + goMaybePairF _ _ = Nothing + + goList :: + NP ConcreteClassifier xs + -> NP ConcreteClassifier ys + -> Maybe (xs :~: ys) + goList Nil Nil = Just Refl + goList (x :* xs) (y :* ys) = (\Refl Refl -> Refl) <$> go x y <*> goList xs ys + goList Nil (_ :* _) = Nothing + goList (_ :* _) Nil = Nothing + + -- Make sure we get a warning if we add another constructor + _checkAllCases :: ConcreteClassifier a -> () + _checkAllCases = \case + -- Primitive types + + CC_Bool -> () + CC_Char -> () + CC_Double -> () + CC_Float -> () + CC_Int -> () + CC_Int8 -> () + CC_Int16 -> () + CC_Int32 -> () + CC_Int64 -> () + CC_Integer -> () + CC_Ordering -> () + CC_Unit -> () + CC_Word -> () + CC_Word8 -> () + CC_Word16 -> () + CC_Word32 -> () + CC_Word64 -> () + + -- String types + + CC_String -> () + CC_BS_Strict -> () + CC_BS_Lazy -> () + CC_BS_Short -> () + CC_Text_Strict -> () + CC_Text_Lazy -> () + + -- Aeson + + CC_Value -> () + + -- Compound + + CC_Maybe{} -> () + CC_Either{} -> () + CC_List{} -> () + CC_Ratio{} -> () + CC_Set{} -> () + CC_Map{} -> () + CC_IntSet{} -> () + CC_IntMap{} -> () + CC_Tuple{} -> () + CC_Sequence{} -> () + CC_Tree{} -> () + + -- Reference cells + + CC_STRef -> () + CC_TVar -> () + CC_MVar -> () + + -- Functions + + CC_Fun -> () + + -- User-defined + + CC_User_NonRec{} -> () + CC_User_Rec{} -> () + CC_User_Unlifted{} -> () diff --git a/tests/Test/RecoverRTTI/Orphans.hs b/tests/Test/RecoverRTTI/Orphans.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/Orphans.hs @@ -0,0 +1,14 @@ +module Test.RecoverRTTI.Orphans () where + +import Debug.RecoverRTTI + +-- | Degenerate 'Eq' instance for functions that always says 'True' +-- +-- When we compare values up to the coercion returned by 'reclassify', we need +-- an 'Eq' instance. We can't compare functions in any meaningful way though, +-- and so we just return 'True' here no matter what. +-- +-- This is an orphan defined in the test suite only, so that users of the +-- library don't have acccess to this (misleading) instance. +instance Eq SomeFun where + _ == _ = True diff --git a/tests/Test/RecoverRTTI/Sanity.hs b/tests/Test/RecoverRTTI/Sanity.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/Sanity.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Test.RecoverRTTI.Sanity (tests) where + +import Debug.RecoverRTTI.Util + +import Test.Tasty +import Test.Tasty.QuickCheck + +import Test.RecoverRTTI.Arbitrary +import Test.RecoverRTTI.ConcreteClassifier + +tests :: TestTree +tests = testGroup "Test.RecoverRTTI.Sanity" [ + testProperty "typeSize" prop_typeSize + ] + +prop_typeSize :: Property +prop_typeSize = + forAll (Blind <$> arbitraryClassifiedGen 10) $ + \(Blind (Some ClassifiedGen{genClassifier})) -> + counterexample ("classifier: " ++ show genClassifier) + $ counterexample ("size: " ++ show (classifierSize genClassifier)) + $ classifierSize genClassifier <= 100 diff --git a/tests/Test/RecoverRTTI/Show.hs b/tests/Test/RecoverRTTI/Show.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/Show.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NumericUnderscores #-} + +-- | Verify that 'anythingToString' produces same result as 'show' +module Test.RecoverRTTI.Show (tests) where + +import Test.Tasty +import Test.Tasty.QuickCheck hiding (classify) + +import Debug.RecoverRTTI +import Debug.RecoverRTTI.Util + +import Test.RecoverRTTI.Arbitrary () +import Test.RecoverRTTI.ConcreteClassifier + +tests :: TestTree +tests = testGroup "Test.RecoverRTTI.Show" [ + testProperty "showGenerated" prop_showGenerated + , testProperty "anythingToString" prop_anythingToString + ] + +-- | Check that the generated value is showable +-- +-- This is a sanity check on the generator. +prop_showGenerated :: Some Value -> Property +prop_showGenerated (Some (Value _cc x)) = + counterexample ("length: " ++ show (length (show x))) + $ property (length (show x) < 1_000_000) + +-- | Compare " normal " 'show' against the " recovered " 'show' +prop_anythingToString :: Some Value -> Property +prop_anythingToString (Some (Value _cc x)) = + counterexample ("inferred: " ++ show (classify x)) + $ within 1_000_000 + $ show x === anythingToString x diff --git a/tests/Test/RecoverRTTI/Staged.hs b/tests/Test/RecoverRTTI/Staged.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/Staged.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | Staged inference +-- +-- Suppose we have a user-defined type such as +-- +-- > data T a = MkT a +-- +-- When we classify a value of type @T a@, 'classify' will give us "one level" +-- type inference only: it will classify this value as +-- +-- > UserDefined (Constr "pkg" "modl" "MkT") +-- +-- It will not attempt to classify the /arguments/ to the constructor. If we +-- /know/ which user-defined types we're interested in, however, we can do +-- full classification by doing "staged inference", repeatedly calling +-- 'classify' at every level. +-- +-- In this module we do staged inference for the user-defined types used in the +-- test suite. The primary purpose of this is to provide evidence that +-- 'classify' gives us enough information to do so. +module Test.RecoverRTTI.Staged ( + Reclassified(..) + , reclassify + , classifyThenReclassify + ) where + +import Control.Monad.Except +import Data.Bifunctor +import Data.Kind +import Data.Map (Map) +import Data.Set (Set) +import Data.SOP hiding (NS(..)) +import Data.Typeable +import Data.Void +import GHC.Exts (Any) +import GHC.Real +import GHC.TypeLits + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Debug.RecoverRTTI +import Debug.RecoverRTTI.Util +import Debug.RecoverRTTI.Util.TypeLevel + +import Test.RecoverRTTI.ConcreteClassifier +import Test.RecoverRTTI.UserDefined + +{------------------------------------------------------------------------------- + Reclassified values +-------------------------------------------------------------------------------} + +-- | Reclassified values +-- +-- We cannot go directly from a @Classifier a@ to a @ConcreteClassifier a@: +-- in the case of a user-defined type, @a@ will be of the form +-- +-- > UserDefined c +-- +-- for some @c@, but we want to return classifier for a specific type, maybe +-- +-- > NonRecursive Char +-- +-- Therefore instead we return a classifier for some other type @b@, but along +-- with a proof that we can /coerce/ from @a@ to @b@. +data Reclassified a where + Reclassified :: ConcreteClassifier b -> (a -> b) -> Reclassified a + +-- | Classify, then reclassify +classifyThenReclassify :: a -> Except String (Reclassified a) +classifyThenReclassify x = + case classified x of + Left closure -> + throwError $ "Failed to classify closure " ++ show closure + Right classifier -> + reclassify classifier + +-- | Reclassify values +-- +-- See detailed description in 'Reclassified'. +reclassify :: Classified a -> Except String (Reclassified a) +reclassify = go + where + go :: Classified a -> Except String (Reclassified a) + go (Classified c x) = case c of + -- Primitive types + + C_Bool -> return $ Reclassified CC_Bool id + C_Char -> return $ Reclassified CC_Char id + C_Double -> return $ Reclassified CC_Double id + C_Float -> return $ Reclassified CC_Float id + C_Int -> return $ Reclassified CC_Int id + C_Int8 -> return $ Reclassified CC_Int8 id + C_Int16 -> return $ Reclassified CC_Int16 id + C_Int32 -> return $ Reclassified CC_Int32 id + C_Int64 -> return $ Reclassified CC_Int64 id + C_Integer -> return $ Reclassified CC_Integer id + C_Ordering -> return $ Reclassified CC_Ordering id + C_Unit -> return $ Reclassified CC_Unit id + C_Word -> return $ Reclassified CC_Word id + C_Word8 -> return $ Reclassified CC_Word8 id + C_Word16 -> return $ Reclassified CC_Word16 id + C_Word32 -> return $ Reclassified CC_Word32 id + C_Word64 -> return $ Reclassified CC_Word64 id + + -- String types + + C_String -> return $ Reclassified CC_String id + C_BS_Strict -> return $ Reclassified CC_BS_Strict id + C_BS_Lazy -> return $ Reclassified CC_BS_Lazy id + C_BS_Short -> return $ Reclassified CC_BS_Short id + C_Text_Strict -> return $ Reclassified CC_Text_Strict id + C_Text_Lazy -> return $ Reclassified CC_Text_Lazy id + + -- Aeson + + C_Value -> return $ Reclassified CC_Value id + + -- Compound + + C_Maybe c' -> goMaybeF fmap CC_Maybe c' + C_Either c' -> goEitherF bimap CC_Either c' + C_List c' -> goMaybeF fmap CC_List c' + C_Ratio c' -> goF coerceRatio CC_Ratio c' + C_Set c' -> goMaybeF coerceSet CC_Set c' + C_Map c' -> goMaybePairF coerceMap CC_Map c' + C_IntSet -> return $ Reclassified CC_IntSet id + C_IntMap c' -> goMaybeF fmap CC_IntMap c' + C_Sequence c' -> goMaybeF fmap CC_Sequence c' + C_Tree c' -> goF fmap CC_Tree c' + + C_Tuple (Classifiers cs) -> + reclassifyTuple <$> (hsequence' (hmap (Comp . reclassify) cs)) + + -- Reference cells + + C_STRef -> return $ Reclassified CC_STRef id + C_TVar -> return $ Reclassified CC_TVar id + C_MVar -> return $ Reclassified CC_MVar id + + -- Functions + + C_Fun -> return $ Reclassified CC_Fun id + + -- User-defined + + C_Custom s -> + firstMatch ("Unknown constructor: " ++ prettyKnownConstr s) [ + reclassifyF CC_User_NonRec s x + , reclassifyF CC_User_Rec s x + , reclassifyF CC_User_Unlifted s x + ] + + goMaybeF :: forall f a. + (forall x x'. (x -> x') -> f x -> f x') + -> (forall x. MaybeF ConcreteClassifier x -> ConcreteClassifier (f x)) + -> MaybeF Classified a + -> Except String (Reclassified (f a)) + goMaybeF _ cc FNothing = + return $ Reclassified (cc FNothing) id + goMaybeF coerce cc (FJust x') = + aux <$> reclassify x' + where + aux :: Reclassified x -> Reclassified (f x) + aux (Reclassified c_x f_x) = + Reclassified (cc (FJust c_x)) (coerce f_x) + + goEitherF :: forall f a b. + (forall x x' y y'. (x -> x') -> (y -> y') -> f x y -> f x' y') + -> (forall x y. EitherF ConcreteClassifier x y -> ConcreteClassifier (f x y)) + -> EitherF Classified a b + -> Except String (Reclassified (f a b)) + goEitherF coerce cc (FLeft x') = + aux <$> reclassify x' + where + aux :: Reclassified x -> Reclassified (f x Void) + aux (Reclassified c_x f_x) = + Reclassified (cc (FLeft c_x)) (coerce f_x id) + goEitherF coerce cc (FRight y') = + aux <$> reclassify y' + where + aux :: Reclassified y -> Reclassified (f Void y) + aux (Reclassified c_y f_y) = + Reclassified (cc (FRight c_y)) (coerce id f_y) + + goMaybePairF :: forall f a b. + (forall x x' y y'. (x -> x') -> (y -> y') -> f x y -> f x' y') + -> (forall x y. MaybePairF ConcreteClassifier x y -> ConcreteClassifier (f x y)) + -> MaybePairF Classified a b + -> Except String (Reclassified (f a b)) + goMaybePairF _ cc FNothingPair = + return $ Reclassified (cc FNothingPair) id + goMaybePairF coerce cc (FJustPair x' y') = + aux <$> reclassify x' <*> reclassify y' + where + aux :: Reclassified x -> Reclassified y -> Reclassified (f x y) + aux (Reclassified c_x f_x) (Reclassified c_y f_y) = + Reclassified (cc (FJustPair c_x c_y)) (coerce f_x f_y) + + goF :: forall f a. + (forall x x'. (x -> x') -> f x -> f x') + -> (forall x. ConcreteClassifier x -> ConcreteClassifier (f x)) + -> Classified a + -> Except String (Reclassified (f a)) + goF coerce cc x' = + aux <$> reclassify x' + where + aux :: Reclassified x -> Reclassified (f x) + aux (Reclassified c_x f_x) = + Reclassified (cc c_x) (coerce f_x) + +reclassifyTuple :: + (SListI xs, IsValidSize (Length xs)) + => NP Reclassified xs -> Reclassified (WrappedTuple xs) +reclassifyTuple = \cs -> + go cs $ \cs' f -> + Reclassified (CC_Tuple (ConcreteClassifiers cs')) f + where + go :: forall xs r. + (SListI xs, IsValidSize (Length xs)) + => NP Reclassified xs + -> (forall ys. + (SListI ys, Length ys ~ Length xs) + => NP ConcreteClassifier ys + -> (WrappedTuple xs -> WrappedTuple ys) + -> r + ) + -> r + go Nil k = k Nil id + go (x :* xs) k = smallerIsValid (Proxy @(Length xs)) $ + go xs $ \np f_np -> + case x of + Reclassified y f_y -> + k (y :* np) (bimapTuple f_y f_np) + +{------------------------------------------------------------------------------- + Lift coercions to non-functor types +-------------------------------------------------------------------------------} + +coerceRatio :: (x -> x') -> Ratio x -> Ratio x' +coerceRatio f (x :% y) = f x :% f y + +coerceSet :: (x -> x') -> Set x -> Set x' +coerceSet f = Set.fromDistinctAscList . map f . Set.toAscList + +coerceMap :: (x -> x') -> (y -> y') -> Map x y -> Map x' y' +coerceMap f g = Map.fromDistinctAscList . map (bimap f g) . Map.toAscList + +{------------------------------------------------------------------------------- + When we reclassify values of user-defined types with type arguments, we need + to know that if @c@ is a value of, say, @T a@, it is also a value of @T b@, + for all @b@. This is what enables staged inference: we know it's a constructor + of @T x@ for /some/ @x@, and then as a second step figure out what @x@ is. +-------------------------------------------------------------------------------} + +data ConstrOfF f c a = ConstrOfF (IsConstrOf (f a) c) + +unsafeCoerceF :: Poly (ConstrOfF f c) -> UserDefined c -> f a +unsafeCoerceF (Poly (ConstrOfF isConstrOf)) = aux isConstrOf + where + aux :: forall a c. IsConstrOf a c -> UserDefined c -> a + aux IsConstrOf = unsafeCoerceUserDefined + +checkConstrOfF :: + forall f c. ( + Phantom (ConstrOfF f c) + , SingI (Constrs (f Any)) + ) + => Sing c -> Maybe (Poly (ConstrOfF f c)) +checkConstrOfF c = maybePoly (ConstrOfF <$> checkIsConstrOf @(f Any) c) + +reclassifyF :: + forall (f :: Type -> Type) (c :: Constr Symbol). ( + Phantom (ConstrOfF f c) + , SingI (Constrs (f Any)) + , Traversable f + , Typeable f + ) + => (forall a. MaybeF ConcreteClassifier a -> ConcreteClassifier (f a)) + -> Sing (c :: Constr Symbol) + -> UserDefined c + -> Except String (Maybe (Reclassified (UserDefined c))) +reclassifyF cc = \c x -> + case checkConstrOfF @f c of + Nothing -> + return Nothing + Just constrOfF -> + case checkEmptyTraversable (unsafeCoerceF constrOfF x) of + Right _ -> + return . Just $ Reclassified (cc FNothing) (unsafeCoerceF constrOfF) + Left x' -> do + Just . aux constrOfF <$> classifyThenReclassify x' + where + aux :: Poly (ConstrOfF f c) + -> Reclassified a -- Classification of the elements + -> Reclassified (UserDefined c) -- Classification of the container + aux constrOfF (Reclassified c f) = + Reclassified (cc (FJust c)) (fmap f . unsafeCoerceF constrOfF) + +{------------------------------------------------------------------------------- + Prove that the functors of our user-defined types are indeed parametric + + NOTE: It's kinda frustrating that we have to repeat this for every type. + That's non-trivial to fix though; a polymorphic function would need as + quantified constraint that + + > forall a b. Constrs (f a) ~ Constrs (f b) + + but that is not legal Haskell: we cannot use type synonyms in quantified + constraints (frustratingly and unnecessarily). +-------------------------------------------------------------------------------} + +instance Phantom (ConstrOfF NonRecursive c) where + phantom (ConstrOfF IsConstrOf) = ConstrOfF IsConstrOf + +instance Phantom (ConstrOfF Recursive c) where + phantom (ConstrOfF IsConstrOf) = ConstrOfF IsConstrOf + +instance Phantom (ConstrOfF ContainsUnlifted c) where + phantom (ConstrOfF IsConstrOf) = ConstrOfF IsConstrOf + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +firstMatch :: forall e a. e -> [Except e (Maybe a)] -> Except e a +firstMatch err = go + where + go :: [Except e (Maybe a)] -> Except e a + go [] = throwError err + go (x:xs) = x >>= maybe (go xs) return diff --git a/tests/Test/RecoverRTTI/UserDefined.hs b/tests/Test/RecoverRTTI/UserDefined.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RecoverRTTI/UserDefined.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} + +-- | Just some examples of user-defined types +module Test.RecoverRTTI.UserDefined ( + NonRecursive(..) + , Recursive(..) + , recursiveFromList + , ContainsUnlifted -- opaque + , exampleContainsUnlifted + ) where + +import GHC.Generics +import GHC.IO +import GHC.Prim + +{------------------------------------------------------------------------------- + User-defined datatypes +-------------------------------------------------------------------------------} + +-- | Example of a non-recursive user-defined type +data NonRecursive a = NR1 Int | NR2 a Bool + deriving (Show, Eq, Generic, Functor, Foldable, Traversable) + +-- | Example of a recursive user-defined type +data Recursive a = RNil | RCons a (Recursive a) + deriving (Show, Eq, Generic, Functor, Foldable, Traversable) + +recursiveFromList :: [a] -> Recursive a +recursiveFromList = foldr RCons RNil + +{------------------------------------------------------------------------------- + Example of a type with an unlifted value + + Most instances here don't really make much sense; this is just here to + verify we don't crash when coming across unlifted values +-------------------------------------------------------------------------------} + +-- | Example of a user-defined type containing something unlifted +data ContainsUnlifted a = NothingHere | ContainsUnlifted (MutableArray# RealWorld Int) a + deriving (Functor, Foldable, Traversable) + +-- We can't derive a Generic instance, we must produce just enough info so that +-- we can do the right type casts +instance Generic (ContainsUnlifted a) where + type Rep (ContainsUnlifted a) = Rep_ContainsUnlifted + + from = error "'from' not defined for ContainsUnlifted" + to = error "'to' not defined for ContainsUnlifted" + +-- We don't bother specifiying the arguments to the constructors +type Rep_ContainsUnlifted = + M1 D ('MetaData "ContainsUnlifted" "Test.RecoverRTTI.UserDefined" "main" 'False) + ( M1 C ('MetaCons "NothingHere" 'PrefixI 'False) U1 + :+: + M1 C ('MetaCons "ContainsUnlifted" 'PrefixI 'False) U1 + ) + +instance Show a => Show (ContainsUnlifted a) where + showsPrec _ NothingHere = + showString "NothingHere" + showsPrec p (ContainsUnlifted _ x) = showParen (p >= 11) $ + showString "ContainsUnlifted " + . showsPrec 11 x + +instance Eq (ContainsUnlifted a) where + _ == _ = True + +exampleContainsUnlifted :: ContainsUnlifted () +{-# NOINLINE exampleContainsUnlifted #-} +exampleContainsUnlifted = unsafePerformIO $ IO $ \world -> + let !(# world', arr #) = newArray# 5# 0 world + in (# world', ContainsUnlifted arr () #)