staged-gg (empty) → 0.1
raw patch · 10 files changed
+2577/−0 lines, 10 filesdep +basedep +containersdep +generic-deriving
Dependencies added: base, containers, generic-deriving, template-haskell, th-abstraction, th-lift
Files
- LICENSE +30/−0
- src/Generics/Deriving/TH/Internal.hs +884/−0
- src/Generics/Deriving/TH/Post4_9.hs +137/−0
- src/Staged/GHC/Generics.hs +71/−0
- src/Staged/GHC/Generics/Instances.hs +464/−0
- src/Staged/GHC/Generics/Internal.hs +7/−0
- src/Staged/GHC/Generics/TH.hs +642/−0
- src/Staged/GHC/Generics/TH/Names.hs +93/−0
- src/Staged/GHC/Generics/Types.hs +190/−0
- staged-gg.cabal +59/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020, Oleg Grenrus, Andres Löh++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 Oleg Grenrus 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.
+ src/Generics/Deriving/TH/Internal.hs view
@@ -0,0 +1,884 @@+{-# LANGUAGE CPP #-}++{- |+Module : Generics.Deriving.TH.Internal+Copyright : (c) 2008--2009 Universiteit Utrecht+License : BSD3++Maintainer : generics@haskell.org+Stability : experimental+Portability : non-portable++Template Haskell-related utilities.+-}++module Generics.Deriving.TH.Internal where++import Control.Monad (unless)++import Data.Char (isAlphaNum, ord)+import Data.Foldable (foldr')+import Data.List+import qualified Data.Map as Map+import Data.Map as Map (Map)+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set+import Data.Set (Set)++import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr (pprint)+import Language.Haskell.TH.Syntax++#ifndef CURRENT_PACKAGE_KEY+#error "No CURRENT_PACKAGE_KEY+#endif++-------------------------------------------------------------------------------+-- Expanding type synonyms+-------------------------------------------------------------------------------++type TypeSubst = Map Name Type++applySubstitutionKind :: Map Name Kind -> Type -> Type+#if MIN_VERSION_template_haskell(2,8,0)+applySubstitutionKind = applySubstitution+#else+applySubstitutionKind _ t = t+#endif++substNameWithKind :: Name -> Kind -> Type -> Type+substNameWithKind n k = applySubstitutionKind (Map.singleton n k)++substNamesWithKindStar :: [Name] -> Type -> Type+substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns++-------------------------------------------------------------------------------+-- StarKindStatus+-------------------------------------------------------------------------------++-- | Whether a type is not of kind *, is of kind *, or is a kind variable.+data StarKindStatus = NotKindStar+ | KindStar+ | IsKindVar Name+ deriving Eq++-- | Does a Type have kind * or k (for some kind variable k)?+canRealizeKindStar :: Type -> StarKindStatus+canRealizeKindStar t+ | hasKindStar t = KindStar+ | otherwise = case t of+#if MIN_VERSION_template_haskell(2,8,0)+ SigT _ (VarT k) -> IsKindVar k+#endif+ _ -> NotKindStar++-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.+-- Otherwise, returns 'Nothing'.+starKindStatusToName :: StarKindStatus -> Maybe Name+starKindStatusToName (IsKindVar n) = Just n+starKindStatusToName _ = Nothing++-- | Concat together all of the StarKindStatuses that are IsKindVar and extract+-- the kind variables' Names out.+catKindVarNames :: [StarKindStatus] -> [Name]+catKindVarNames = mapMaybe starKindStatusToName++-------------------------------------------------------------------------------+-- Assorted utilities+-------------------------------------------------------------------------------++-- | Returns True if a Type has kind *.+hasKindStar :: Type -> Bool+hasKindStar VarT{} = True+#if MIN_VERSION_template_haskell(2,8,0)+hasKindStar (SigT _ StarT) = True+#else+hasKindStar (SigT _ StarK) = True+#endif+hasKindStar _ = False++-- | Converts a VarT or a SigT into Just the corresponding TyVarBndr.+-- Converts other Types to Nothing.+typeToTyVarBndr :: Type -> Maybe TyVarBndrUnit+typeToTyVarBndr (VarT n) = Just (plainTV n)+typeToTyVarBndr (SigT (VarT n) k) = Just (kindedTV n k)+typeToTyVarBndr _ = Nothing++-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.+typeKind :: Type -> Kind+typeKind (SigT _ k) = k+typeKind _ = starK++-- | Turns+--+-- @+-- [a, b] c+-- @+--+-- into+--+-- @+-- a -> b -> c+-- @+makeFunType :: [Type] -> Type -> Type+makeFunType argTys resTy = foldr' (AppT . AppT ArrowT) resTy argTys++-- | Turns+--+-- @+-- [k1, k2] k3+-- @+--+-- into+--+-- @+-- k1 -> k2 -> k3+-- @+makeFunKind :: [Kind] -> Kind -> Kind+#if MIN_VERSION_template_haskell(2,8,0)+makeFunKind = makeFunType+#else+makeFunKind argKinds resKind = foldr' ArrowK resKind argKinds+#endif++-- | Is the given type a type family constructor (and not a data family constructor)?+isTyFamily :: Type -> Q Bool+isTyFamily (ConT n) = do+ info <- reify n+ return $ case info of+#if MIN_VERSION_template_haskell(2,11,0)+ FamilyI OpenTypeFamilyD{} _ -> True+#elif MIN_VERSION_template_haskell(2,7,0)+ FamilyI (FamilyD TypeFam _ _ _) _ -> True+#else+ TyConI (FamilyD TypeFam _ _ _) -> True+#endif+#if MIN_VERSION_template_haskell(2,9,0)+ FamilyI ClosedTypeFamilyD{} _ -> True+#endif+ _ -> False+isTyFamily _ = return False++-- | True if the type does not mention the Name+ground :: Type -> Name -> Bool+ground (AppT t1 t2) name = ground t1 name && ground t2 name+ground (SigT t _) name = ground t name+ground (VarT t) name = t /= name+ground ForallT{} _ = rankNError+ground _ _ = True++-- | Construct a type via curried application.+applyTyToTys :: Type -> [Type] -> Type+applyTyToTys = foldl' AppT++-- | Apply a type constructor name to type variable binders.+applyTyToTvbs :: Name -> [TyVarBndr_ spec] -> Type+applyTyToTvbs = foldl' (\a -> AppT a . tyVarBndrToType) . ConT++-- | Split an applied type into its individual components. For example, this:+--+-- @+-- Either Int Char+-- @+--+-- would split to this:+--+-- @+-- [Either, Int, Char]+-- @+unapplyTy :: Type -> [Type]+unapplyTy = reverse . go+ where+ go :: Type -> [Type]+ go (AppT t1 t2) = t2 : go t1+ go (SigT t _) = go t+ go (ForallT _ _ t) = go t+ go t = [t]++-- | Split a type signature by the arrows on its spine. For example, this:+--+-- @+-- forall a b. (a -> b) -> Char -> ()+-- @+--+-- would split to this:+--+-- @+-- ([a, b], [a -> b, Char, ()])+-- @+uncurryTy :: Type -> ([TyVarBndrSpec], [Type])+uncurryTy (AppT (AppT ArrowT t1) t2) =+ let (tvbs, tys) = uncurryTy t2+ in (tvbs, t1:tys)+uncurryTy (SigT t _) = uncurryTy t+uncurryTy (ForallT tvbs _ t) =+ let (tvbs', tys) = uncurryTy t+ in (tvbs ++ tvbs', tys)+uncurryTy t = ([], [t])++-- | Like uncurryType, except on a kind level.+uncurryKind :: Kind -> ([TyVarBndrSpec], [Kind])+#if MIN_VERSION_template_haskell(2,8,0)+uncurryKind = uncurryTy+#else+uncurryKind (ArrowK k1 k2) =+ let (kvbs, ks) = uncurryKind k2+ in (kvbs, k1:ks)+uncurryKind k = ([], [k])+#endif++tyVarBndrToType :: TyVarBndr_ spec -> Type+tyVarBndrToType = elimTV VarT (\n k -> SigT (VarT n) k)++-- | Generate a list of fresh names with a common prefix, and numbered suffixes.+newNameList :: String -> Int -> Q [Name]+newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]++-- | Checks to see if the last types in a data family instance can be safely eta-+-- reduced (i.e., dropped), given the other types. This checks for three conditions:+--+-- (1) All of the dropped types are type variables+-- (2) All of the dropped types are distinct+-- (3) None of the remaining types mention any of the dropped types+canEtaReduce :: [Type] -> [Type] -> Bool+canEtaReduce remaining dropped =+ all isTyVar dropped+ -- Make sure not to pass something of type [Type], since Type+ -- didn't have an Ord instance until template-haskell-2.10.0.0+ && allDistinct droppedNames+ && not (any (`mentionsName` droppedNames) remaining)+ where+ droppedNames :: [Name]+ droppedNames = map varTToName dropped++-- | Extract the Name from a type variable. If the argument Type is not a+-- type variable, throw an error.+varTToName :: Type -> Name+varTToName (VarT n) = n+varTToName (SigT t _) = varTToName t+varTToName _ = error "Not a type variable!"++-- | Is the given type a variable?+isTyVar :: Type -> Bool+isTyVar VarT{} = True+isTyVar (SigT t _) = isTyVar t+isTyVar _ = False++-- | Is the given kind a variable?+isKindVar :: Kind -> Bool+#if MIN_VERSION_template_haskell(2,8,0)+isKindVar = isTyVar+#else+isKindVar _ = False -- There are no kind variables+#endif++-- | Returns 'True' is a 'Type' contains no type variables.+isTypeMonomorphic :: Type -> Bool+isTypeMonomorphic = go+ where+ go :: Type -> Bool+ go (AppT t1 t2) = go t1 && go t2+ go (SigT t _k) = go t+#if MIN_VERSION_template_haskell(2,8,0)+ && go _k+#endif+ go VarT{} = False+ go _ = True++-- | Peel off a kind signature from a Type (if it has one).+unSigT :: Type -> Type+unSigT (SigT t _) = t+unSigT t = t++-- | Peel off a kind signature from a TyVarBndr (if it has one).+unKindedTV :: TyVarBndrUnit -> TyVarBndrUnit+unKindedTV tvb = elimTV (\_ -> tvb) (\n _ -> plainTV n) tvb++-- | Does the given type mention any of the Names in the list?+mentionsName :: Type -> [Name] -> Bool+mentionsName = go+ where+ go :: Type -> [Name] -> Bool+ go (AppT t1 t2) names = go t1 names || go t2 names+ go (SigT t _k) names = go t names+#if MIN_VERSION_template_haskell(2,8,0)+ || go _k names+#endif+ go (VarT n) names = n `elem` names+ go _ _ = False++-- | Are all of the items in a list (which have an ordering) distinct?+--+-- This uses Set (as opposed to nub) for better asymptotic time complexity.+allDistinct :: Ord a => [a] -> Bool+allDistinct = allDistinct' Set.empty+ where+ allDistinct' :: Ord a => Set a -> [a] -> Bool+ allDistinct' uniqs (x:xs)+ | x `Set.member` uniqs = False+ | otherwise = allDistinct' (Set.insert x uniqs) xs+ allDistinct' _ _ = True++fst3 :: (a, b, c) -> a+fst3 (a, _, _) = a++snd3 :: (a, b, c) -> b+snd3 (_, b, _) = b++trd3 :: (a, b, c) -> c+trd3 (_, _, c) = c++shrink :: (a, b, c) -> (b, c)+shrink (_, b, c) = (b, c)++foldBal :: (a -> a -> a) -> a -> [a] -> a+foldBal _ x [] = x+foldBal _ _ [y] = y+foldBal op x l = let (a,b) = splitAt (length l `div` 2) l+ in foldBal op x a `op` foldBal op x b++isNewtypeVariant :: DatatypeVariant_ -> Bool+isNewtypeVariant Datatype_ = False+isNewtypeVariant Newtype_ = True+isNewtypeVariant (DataInstance_ {}) = False+isNewtypeVariant (NewtypeInstance_ {}) = True++-- | Indicates whether Generic or Generic1 is being derived.+data GenericClass = Generic | Generic1 deriving Enum++-- | Like 'GenericArity', but bundling two things in the 'Gen1' case:+--+-- 1. The 'Name' of the last type parameter.+-- 2. If that last type parameter had kind k (where k is some kind variable),+-- then it has 'Just' the kind variable 'Name'. Otherwise, it has 'Nothing'.+data GenericKind = Gen0+ | Gen1 Name (Maybe Name)++-- Determines the universally quantified type variables (possibly after+-- substituting * in the case of Generic1) and the last type parameter name+-- (if there is one).+genericKind :: GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind)+genericKind gClass tySynVars =+ case gClass of+ Generic -> (freeVariablesWellScoped tySynVars, Gen0)+ Generic1 -> (freeVariablesWellScoped initArgs, Gen1 (varTToName lastArg) mbLastArgKindName)+ where+ -- Everything below is only used for Generic1.+ initArgs :: [Type]+ initArgs = init tySynVars++ lastArg :: Type+ lastArg = last tySynVars++ mbLastArgKindName :: Maybe Name+ mbLastArgKindName = starKindStatusToName+ $ canRealizeKindStar lastArg++-- | A version of 'DatatypeVariant' in which the data family instance+-- constructors come equipped with the 'ConstructorInfo' of the first+-- constructor in the family instance (for 'Name' generation purposes).+data DatatypeVariant_+ = Datatype_+ | Newtype_+ | DataInstance_ ConstructorInfo+ | NewtypeInstance_ ConstructorInfo+ deriving Show++showsDatatypeVariant :: DatatypeVariant_ -> ShowS+showsDatatypeVariant variant = (++ '_':label)+ where+ dataPlain :: String+ dataPlain = "Plain"++ dataFamily :: ConstructorInfo -> String+ dataFamily con = "Family_" ++ sanitizeName (nameBase $ constructorName con)++ label :: String+ label = case variant of+ Datatype_ -> dataPlain+ Newtype_ -> dataPlain+ DataInstance_ con -> dataFamily con+ NewtypeInstance_ con -> dataFamily con++showNameQual :: Name -> String+showNameQual = sanitizeName . showQual+ where+ showQual (Name _ (NameQ m)) = modString m+ showQual (Name _ (NameG _ pkg m)) = pkgString pkg ++ ":" ++ modString m+ showQual _ = ""++-- | Credit to Víctor López Juan for this trick+sanitizeName :: String -> String+sanitizeName nb = 'N':(+ nb >>= \x -> case x of+ c | isAlphaNum c || c == '\''-> [c]+ '_' -> "__"+ c -> "_" ++ show (ord c))++-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce+-- function for the criteria it would have to meet).+etaReductionError :: Type -> Q a+etaReductionError instanceType = fail $+ "Cannot eta-reduce to an instance of form \n\tinstance (...) => "+ ++ pprint instanceType++-- | Either the given data type doesn't have enough type variables, or one of+-- the type variables to be eta-reduced cannot realize kind *.+derivingKindError :: Name -> Q a+derivingKindError tyConName = fail+ . showString "Cannot derive well-kinded instance of form ‘Generic1 "+ . showParen True+ ( showString (nameBase tyConName)+ . showString " ..."+ )+ . showString "‘\n\tClass Generic1 expects an argument of kind * -> *"+ $ ""++outOfPlaceTyVarError :: Q a+outOfPlaceTyVarError = fail+ "Type applied to an argument involving the last parameter is not of kind * -> *"++-- | Cannot have a constructor argument of form (forall a1 ... an. <type>)+-- when deriving Generic(1)+rankNError :: a+rankNError = error "Cannot have polymorphic arguments"++-- | Boilerplate for top level splices.+--+-- The given Name must meet one of two criteria:+--+-- 1. It must be the name of a type constructor of a plain data type or newtype.+-- 2. It must be the name of a data family instance or newtype instance constructor.+--+-- Any other value will result in an exception.+reifyDataInfo :: Name+ -> Q (Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_))+reifyDataInfo name = do+ return $ Left $ ns ++ " Could not reify " ++ nameBase name+ `recover`+ do DatatypeInfo { datatypeContext = ctxt+ , datatypeName = parentName+ , datatypeInstTypes = tys+ , datatypeVariant = variant+ , datatypeCons = cons+ } <- reifyDatatype name+ let variant_ = case variant of+ Datatype -> Datatype_+ Newtype -> Newtype_+ -- This isn't total, but the API requires that the data+ -- family instance have at least one constructor anyways,+ -- so this will always succeed.+ DataInstance -> DataInstance_ $ head cons+ NewtypeInstance -> NewtypeInstance_ $ head cons+ checkDataContext parentName ctxt $ Right (parentName, tys, cons, variant_)+ where+ ns :: String+ ns = "Generics.Deriving.TH.reifyDataInfo: "++-- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts,+-- so check to make sure the Cxt field of a datatype is null.+checkDataContext :: Name -> Cxt -> a -> Q a+checkDataContext _ [] x = return x+checkDataContext dataName _ _ = fail $+ nameBase dataName ++ " must not have a datatype context"++-- | Deriving Generic(1) doesn't work with ExistentialQuantification or GADTs.+checkExistentialContext :: Name -> [TyVarBndrUnit] -> Cxt -> Q ()+checkExistentialContext conName vars ctxt =+ unless (null vars && null ctxt) $ fail $+ nameBase conName ++ " must be a vanilla data constructor"++#if MIN_VERSION_template_haskell(2,17,0)+type TyVarBndr_ spec = TyVarBndr spec+#else+type TyVarBndr_ spec = TyVarBndr+type TyVarBndrSpec = TyVarBndr+type TyVarBndrUnit = TyVarBndr+#endif++elimTV :: (Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ spec -> r+#if MIN_VERSION_template_haskell(2,17,0)+elimTV ptv _ktv (PlainTV n _) = ptv n+elimTV _ptv ktv (KindedTV n _ k) = ktv n k+#else+elimTV ptv _ktv (PlainTV n) = ptv n+elimTV _ptv ktv (KindedTV n k) = ktv n k+#endif++-------------------------------------------------------------------------------+-- Manually quoted names+-------------------------------------------------------------------------------++-- By manually generating these names we avoid needing to use the+-- TemplateHaskell language extension when compiling the generic-deriving library.+-- This allows the library to be used in stage1 cross-compilers.++gdPackageKey :: String+gdPackageKey = CURRENT_PACKAGE_KEY++mkGD4'4_d :: String -> Name+#if MIN_VERSION_base(4,6,0)+mkGD4'4_d = mkNameG_d "base" "GHC.Generics"+#elif MIN_VERSION_base(4,4,0)+mkGD4'4_d = mkNameG_d "ghc-prim" "GHC.Generics"+#else+mkGD4'4_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal"+#endif++mkGD4'9_d :: String -> Name+#if MIN_VERSION_base(4,9,0)+mkGD4'9_d = mkNameG_d "base" "GHC.Generics"+#else+mkGD4'9_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal"+#endif++mkGD4'4_tc :: String -> Name+#if MIN_VERSION_base(4,6,0)+mkGD4'4_tc = mkNameG_tc "base" "GHC.Generics"+#elif MIN_VERSION_base(4,4,0)+mkGD4'4_tc = mkNameG_tc "ghc-prim" "GHC.Generics"+#else+mkGD4'4_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal"+#endif++mkGD4'9_tc :: String -> Name+#if MIN_VERSION_base(4,9,0)+mkGD4'9_tc = mkNameG_tc "base" "GHC.Generics"+#else+mkGD4'9_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal"+#endif++mkGD4'4_v :: String -> Name+#if MIN_VERSION_base(4,6,0)+mkGD4'4_v = mkNameG_v "base" "GHC.Generics"+#elif MIN_VERSION_base(4,4,0)+mkGD4'4_v = mkNameG_v "ghc-prim" "GHC.Generics"+#else+mkGD4'4_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal"+#endif++mkGD4'9_v :: String -> Name+#if MIN_VERSION_base(4,9,0)+mkGD4'9_v = mkNameG_v "base" "GHC.Generics"+#else+mkGD4'9_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal"+#endif++mkBaseName_d :: String -> String -> Name+mkBaseName_d = mkNameG_d "base"++mkGHCPrimName_d :: String -> String -> Name+mkGHCPrimName_d = mkNameG_d "ghc-prim"++mkGHCPrimName_tc :: String -> String -> Name+mkGHCPrimName_tc = mkNameG_tc "ghc-prim"++mkGHCPrimName_v :: String -> String -> Name+mkGHCPrimName_v = mkNameG_v "ghc-prim"++comp1DataName :: Name+comp1DataName = mkGD4'4_d "Comp1"++infixDataName :: Name+infixDataName = mkGD4'4_d "Infix"++k1DataName :: Name+k1DataName = mkGD4'4_d "K1"++l1DataName :: Name+l1DataName = mkGD4'4_d "L1"++leftAssociativeDataName :: Name+leftAssociativeDataName = mkGD4'4_d "LeftAssociative"++m1DataName :: Name+m1DataName = mkGD4'4_d "M1"++notAssociativeDataName :: Name+notAssociativeDataName = mkGD4'4_d "NotAssociative"++par1DataName :: Name+par1DataName = mkGD4'4_d "Par1"++prefixDataName :: Name+prefixDataName = mkGD4'4_d "Prefix"++productDataName :: Name+productDataName = mkGD4'4_d ":*:"++r1DataName :: Name+r1DataName = mkGD4'4_d "R1"++rec1DataName :: Name+rec1DataName = mkGD4'4_d "Rec1"++rightAssociativeDataName :: Name+rightAssociativeDataName = mkGD4'4_d "RightAssociative"++u1DataName :: Name+u1DataName = mkGD4'4_d "U1"++uAddrDataName :: Name+uAddrDataName = mkGD4'9_d "UAddr"++uCharDataName :: Name+uCharDataName = mkGD4'9_d "UChar"++uDoubleDataName :: Name+uDoubleDataName = mkGD4'9_d "UDouble"++uFloatDataName :: Name+uFloatDataName = mkGD4'9_d "UFloat"++uIntDataName :: Name+uIntDataName = mkGD4'9_d "UInt"++uWordDataName :: Name+uWordDataName = mkGD4'9_d "UWord"++c1TypeName :: Name+c1TypeName = mkGD4'4_tc "C1"++composeTypeName :: Name+composeTypeName = mkGD4'4_tc ":.:"++constructorTypeName :: Name+constructorTypeName = mkGD4'4_tc "Constructor"++d1TypeName :: Name+d1TypeName = mkGD4'4_tc "D1"++genericTypeName :: Name+genericTypeName = mkGD4'4_tc "Generic"++generic1TypeName :: Name+generic1TypeName = mkGD4'4_tc "Generic1"++datatypeTypeName :: Name+datatypeTypeName = mkGD4'4_tc "Datatype"++noSelectorTypeName :: Name+noSelectorTypeName = mkGD4'4_tc "NoSelector"++par1TypeName :: Name+par1TypeName = mkGD4'4_tc "Par1"++productTypeName :: Name+productTypeName = mkGD4'4_tc ":*:"++rec0TypeName :: Name+rec0TypeName = mkGD4'4_tc "Rec0"++rec1TypeName :: Name+rec1TypeName = mkGD4'4_tc "Rec1"++repTypeName :: Name+repTypeName = mkGD4'4_tc "Rep"++rep1TypeName :: Name+rep1TypeName = mkGD4'4_tc "Rep1"++s1TypeName :: Name+s1TypeName = mkGD4'4_tc "S1"++selectorTypeName :: Name+selectorTypeName = mkGD4'4_tc "Selector"++sumTypeName :: Name+sumTypeName = mkGD4'4_tc ":+:"++u1TypeName :: Name+u1TypeName = mkGD4'4_tc "U1"++uAddrTypeName :: Name+uAddrTypeName = mkGD4'9_tc "UAddr"++uCharTypeName :: Name+uCharTypeName = mkGD4'9_tc "UChar"++uDoubleTypeName :: Name+uDoubleTypeName = mkGD4'9_tc "UDouble"++uFloatTypeName :: Name+uFloatTypeName = mkGD4'9_tc "UFloat"++uIntTypeName :: Name+uIntTypeName = mkGD4'9_tc "UInt"++uWordTypeName :: Name+uWordTypeName = mkGD4'9_tc "UWord"++v1TypeName :: Name+v1TypeName = mkGD4'4_tc "V1"++conFixityValName :: Name+conFixityValName = mkGD4'4_v "conFixity"++conIsRecordValName :: Name+conIsRecordValName = mkGD4'4_v "conIsRecord"++conNameValName :: Name+conNameValName = mkGD4'4_v "conName"++datatypeNameValName :: Name+datatypeNameValName = mkGD4'4_v "datatypeName"++isNewtypeValName :: Name+isNewtypeValName = mkGD4'4_v "isNewtype"++fromValName :: Name+fromValName = mkGD4'4_v "from"++from1ValName :: Name+from1ValName = mkGD4'4_v "from1"++moduleNameValName :: Name+moduleNameValName = mkGD4'4_v "moduleName"++selNameValName :: Name+selNameValName = mkGD4'4_v "selName"++seqValName :: Name+seqValName = mkGHCPrimName_v "GHC.Prim" "seq"++toValName :: Name+toValName = mkGD4'4_v "to"++to1ValName :: Name+to1ValName = mkGD4'4_v "to1"++uAddrHashValName :: Name+uAddrHashValName = mkGD4'9_v "uAddr#"++uCharHashValName :: Name+uCharHashValName = mkGD4'9_v "uChar#"++uDoubleHashValName :: Name+uDoubleHashValName = mkGD4'9_v "uDouble#"++uFloatHashValName :: Name+uFloatHashValName = mkGD4'9_v "uFloat#"++uIntHashValName :: Name+uIntHashValName = mkGD4'9_v "uInt#"++uWordHashValName :: Name+uWordHashValName = mkGD4'9_v "uWord#"++unComp1ValName :: Name+unComp1ValName = mkGD4'4_v "unComp1"++unK1ValName :: Name+unK1ValName = mkGD4'4_v "unK1"++unPar1ValName :: Name+unPar1ValName = mkGD4'4_v "unPar1"++unRec1ValName :: Name+unRec1ValName = mkGD4'4_v "unRec1"++trueDataName, falseDataName :: Name+#if MIN_VERSION_base(4,4,0)+trueDataName = mkGHCPrimName_d "GHC.Types" "True"+falseDataName = mkGHCPrimName_d "GHC.Types" "False"+#else+trueDataName = mkGHCPrimName_d "GHC.Bool" "True"+falseDataName = mkGHCPrimName_d "GHC.Bool" "False"+#endif++nothingDataName, justDataName :: Name+#if MIN_VERSION_base(4,12,0)+nothingDataName = mkBaseName_d "GHC.Maybe" "Nothing"+justDataName = mkBaseName_d "GHC.Maybe" "Just"+#elif MIN_VERSION_base(4,8,0)+nothingDataName = mkBaseName_d "GHC.Base" "Nothing"+justDataName = mkBaseName_d "GHC.Base" "Just"+#else+nothingDataName = mkBaseName_d "Data.Maybe" "Nothing"+justDataName = mkBaseName_d "Data.Maybe" "Just"+#endif++mkGHCPrim_tc :: String -> Name+mkGHCPrim_tc = mkNameG_tc "ghc-prim" "GHC.Prim"++addrHashTypeName :: Name+addrHashTypeName = mkGHCPrim_tc "Addr#"++charHashTypeName :: Name+charHashTypeName = mkGHCPrim_tc "Char#"++doubleHashTypeName :: Name+doubleHashTypeName = mkGHCPrim_tc "Double#"++floatHashTypeName :: Name+floatHashTypeName = mkGHCPrim_tc "Float#"++intHashTypeName :: Name+intHashTypeName = mkGHCPrim_tc "Int#"++wordHashTypeName :: Name+wordHashTypeName = mkGHCPrim_tc "Word#"++composeValName :: Name+composeValName = mkNameG_v "base" "GHC.Base" "."++errorValName :: Name+errorValName = mkNameG_v "base" "GHC.Err" "error"++fmapValName :: Name+fmapValName = mkNameG_v "base" "GHC.Base" "fmap"++undefinedValName :: Name+undefinedValName = mkNameG_v "base" "GHC.Err" "undefined"++starKindName :: Name+starKindName = mkGHCPrimName_tc "GHC.Prim" "*"++decidedLazyDataName :: Name+decidedLazyDataName = mkGD4'9_d "DecidedLazy"++decidedStrictDataName :: Name+decidedStrictDataName = mkGD4'9_d "DecidedStrict"++decidedUnpackDataName :: Name+decidedUnpackDataName = mkGD4'9_d "DecidedUnpack"++infixIDataName :: Name+infixIDataName = mkGD4'9_d "InfixI"++metaConsDataName :: Name+metaConsDataName = mkGD4'9_d "MetaCons"++metaDataDataName :: Name+metaDataDataName = mkGD4'9_d "MetaData"++metaNoSelDataName :: Name+metaNoSelDataName = mkGD4'9_d "MetaNoSel"++metaSelDataName :: Name+metaSelDataName = mkGD4'9_d "MetaSel"++noSourceStrictnessDataName :: Name+noSourceStrictnessDataName = mkGD4'9_d "NoSourceStrictness"++noSourceUnpackednessDataName :: Name+noSourceUnpackednessDataName = mkGD4'9_d "NoSourceUnpackedness"++prefixIDataName :: Name+prefixIDataName = mkGD4'9_d "PrefixI"++sourceLazyDataName :: Name+sourceLazyDataName = mkGD4'9_d "SourceLazy"++sourceNoUnpackDataName :: Name+sourceNoUnpackDataName = mkGD4'9_d "SourceNoUnpack"++sourceStrictDataName :: Name+sourceStrictDataName = mkGD4'9_d "SourceStrict"++sourceUnpackDataName :: Name+sourceUnpackDataName = mkGD4'9_d "SourceUnpack"++packageNameValName :: Name+packageNameValName = mkGD4'4_v "packageName"
+ src/Generics/Deriving/TH/Post4_9.hs view
@@ -0,0 +1,137 @@+{- |+Module : Generics.Deriving.TH.Post4_9+Copyright : (c) 2008--2009 Universiteit Utrecht+License : BSD3++Maintainer : generics@haskell.org+Stability : experimental+Portability : non-portable++Template Haskell machinery for the type-literal-based variant of GHC+generics introduced in @base-4.9@.+-}++module Generics.Deriving.TH.Post4_9 (+ deriveMeta+ , deriveData+ , deriveConstructors+ , deriveSelectors+ , mkMetaDataType+ , mkMetaConsType+ , mkMetaSelType+ , SelStrictInfo(..)+ , reifySelStrictInfo+ ) where++import Data.Maybe (fromMaybe)++import Generics.Deriving.TH.Internal++import Language.Haskell.TH.Datatype as THAbs+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax++mkMetaDataType :: DatatypeVariant_ -> Name -> Q Type+mkMetaDataType dv n =+ promotedT metaDataDataName+ `appT` litT (strTyLit (nameBase n))+ `appT` litT (strTyLit m)+ `appT` litT (strTyLit pkg)+ `appT` promoteBool (isNewtypeVariant dv)+ where+ m, pkg :: String+ m = fromMaybe (error "Cannot fetch module name!") (nameModule n)+ pkg = fromMaybe (error "Cannot fetch package name!") (namePackage n)++mkMetaConsType :: DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type+mkMetaConsType _ _ n conIsRecord conIsInfix = do+ mbFi <- reifyFixity n+ promotedT metaConsDataName+ `appT` litT (strTyLit (nameBase n))+ `appT` fixityIPromotedType mbFi conIsInfix+ `appT` promoteBool conIsRecord++promoteBool :: Bool -> Q Type+promoteBool True = promotedT trueDataName+promoteBool False = promotedT falseDataName++fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type+fixityIPromotedType mbFi True =+ promotedT infixIDataName+ `appT` promoteAssociativity a+ `appT` litT (numTyLit (toInteger n))+ where+ Fixity n a = fromMaybe defaultFixity mbFi+fixityIPromotedType _ False = promotedT prefixIDataName++promoteAssociativity :: FixityDirection -> Q Type+promoteAssociativity InfixL = promotedT leftAssociativeDataName+promoteAssociativity InfixR = promotedT rightAssociativeDataName+promoteAssociativity InfixN = promotedT notAssociativeDataName++mkMetaSelType :: DatatypeVariant_ -> Name -> Name -> Maybe Name+ -> SelStrictInfo -> Q Type+mkMetaSelType _ _ _ mbF (SelStrictInfo su ss ds) =+ let mbSelNameT = case mbF of+ Just f -> promotedT justDataName `appT` litT (strTyLit (nameBase f))+ Nothing -> promotedT nothingDataName+ in promotedT metaSelDataName+ `appT` mbSelNameT+ `appT` promoteUnpackedness su+ `appT` promoteStrictness ss+ `appT` promoteDecidedStrictness ds++data SelStrictInfo = SelStrictInfo Unpackedness Strictness DecidedStrictness++promoteUnpackedness :: Unpackedness -> Q Type+promoteUnpackedness UnspecifiedUnpackedness = promotedT noSourceUnpackednessDataName+promoteUnpackedness NoUnpack = promotedT sourceNoUnpackDataName+promoteUnpackedness Unpack = promotedT sourceUnpackDataName++promoteStrictness :: Strictness -> Q Type+promoteStrictness UnspecifiedStrictness = promotedT noSourceStrictnessDataName+promoteStrictness Lazy = promotedT sourceLazyDataName+promoteStrictness THAbs.Strict = promotedT sourceStrictDataName++promoteDecidedStrictness :: DecidedStrictness -> Q Type+promoteDecidedStrictness DecidedLazy = promotedT decidedLazyDataName+promoteDecidedStrictness DecidedStrict = promotedT decidedStrictDataName+promoteDecidedStrictness DecidedUnpack = promotedT decidedUnpackDataName++reifySelStrictInfo :: Name -> [FieldStrictness] -> Q [SelStrictInfo]+reifySelStrictInfo conName fs = do+ dcdStrs <- reifyConStrictness conName+ let srcUnpks = map fieldUnpackedness fs+ srcStrs = map fieldStrictness fs+ return $ zipWith3 SelStrictInfo srcUnpks srcStrs dcdStrs++-- | Given the type and the name (as string) for the type to derive,+-- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector'+-- instances.+--+-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,+-- so this function generates no declarations.+deriveMeta :: Name -> Q [Dec]+deriveMeta _ = return []++-- | Given a datatype name, derive a datatype and instance of class 'Datatype'.+--+-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,+-- so this function generates no declarations.+deriveData :: Name -> Q [Dec]+deriveData _ = return []++-- | Given a datatype name, derive datatypes and+-- instances of class 'Constructor'.+--+-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,+-- so this function generates no declarations.+deriveConstructors :: Name -> Q [Dec]+deriveConstructors _ = return []++-- | Given a datatype name, derive datatypes and instances of class 'Selector'.+--+-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,+-- so this function generates no declarations.+deriveSelectors :: Name -> Q [Dec]+deriveSelectors _ = return []
+ src/Staged/GHC/Generics.hs view
@@ -0,0 +1,71 @@+-- |+--+-- @staged-gg@ is a staged version of "GHC.Generics".+-- The abstraction overhead of "GHC.Generics" is removed.+--+-- See https://www.andres-loeh.de/StagedSOP/ paper for description of+-- @staged-sop@, which is staged version of @generics-sop@.+-- The non @generics-sop@ specific parts+-- like sections on Typed Template Haskell, and Type Template Haskell and Constraints,+-- are applicable to @staged-gg@ as well.+--+-- == Examples+--+-- See https://github.com/phadej/staged-gg/tree/master/staged-gg-examples+-- for examples+--+-- == Differences from "GHC.Generics"+--+-- * @staged-gg@ is staged: we have 'Code' in the leaves of used representation.+--+-- * Representation 'Rep' class is additionally parametrised by a type-constructor @q@,+-- which in @staged-gg@ is instantiated to @Code q@.+--+-- * There is no @Rec1@ analogue, we use 'K2', which doesn't have an extra index.+--+-- * There is no @:.:@ and @Rec1@. Instead we use left associative applications of ':@@:' headed with 'Par2'.+-- These changes are discussed in GHC issues+-- [https://gitlab.haskell.org/ghc/ghc/-/issues/15969](#15969) and+-- [https://gitlab.haskell.org/ghc/ghc/-/issues/7492](#7492).+--+-- How 'GHC.Generics.Rep' is different is also described by 'Translate' type family.+--+module Staged.GHC.Generics (+ -- * Generic representation types+ V2,+ U2 (..),+ M2 (..),+ K2 (..),+ Par2 (..),+ (:++:) (..),+ (:**:) (..),+ (:@@:) (..),+ -- * Synonyms for convenience+ D2, C2, S2,+ D, C, S,+ -- * Meta-information+ Datatype (..),+ Constructor (..),+ Selector (..),+ Fixity (..),+ FixityI (..),+ Associativity (..),+ SourceUnpackedness (..),+ SourceStrictness (..),+ DecidedStrictness (..),+ Meta (..),+ -- * Generic type classes+ Generic (..),+ Generic1 (..),+ -- * TH Types+ Code, Quote,+ -- * Utilities+ Translate,+ -- * TH deriving machinery+ deriveGeneric,+ deriveGeneric1,+) where++import Staged.GHC.Generics.Instances ()+import Staged.GHC.Generics.TH+import Staged.GHC.Generics.Types
+ src/Staged/GHC/Generics/Instances.hs view
@@ -0,0 +1,464 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-orphans -Wno-deprecations #-}+-- {-# OPTIONS_GHC -ddump-splices -dsuppress-module-prefixes #-}++-- | This module is a modified version of Generics.SOP.Instances.+-- mostly the same.+module Staged.GHC.Generics.Instances () where++import Staged.GHC.Generics.TH++import Control.Exception+import Data.Char+import Data.Complex+import Data.Data+import Data.Fixed+import Data.Functor.Compose+import qualified Data.Functor.Const+import Data.Functor.Identity+import Data.Functor.Product+import Data.Functor.Sum+import Data.List.NonEmpty+import qualified Data.Monoid+import Data.Ord+import qualified Data.Semigroup+import Data.Version+import Data.Void+import Foreign.C.Error+import Foreign.C.Types+import GHC.ByteOrder+import GHC.Conc+import GHC.ExecutionStack+import GHC.Exts+-- import GHC.Events -- platform-specific, omitted+import GHC.Fingerprint+import GHC.Float+import qualified GHC.Generics+import GHC.IO.Buffer+import GHC.IO.Device+import GHC.IO.Encoding+import GHC.IO.Encoding.Failure+import GHC.IO.Exception+import GHC.IO.Handle+import GHC.RTS.Flags+import qualified GHC.Stack+import GHC.StaticPtr+import GHC.Stats+import System.Console.GetOpt+import System.IO+import Text.Printf+import Text.Read.Lex++-- Types from the Prelude:++-- there is manual instance for this+-- deriveGeneric ''Bool++deriveGeneric ''Ordering+deriveGeneric ''Maybe+deriveGeneric ''Either+deriveGeneric ''()+deriveGeneric ''(,) -- 2+deriveGeneric ''(,,)+deriveGeneric ''(,,,)+deriveGeneric ''(,,,,) -- 5+deriveGeneric ''(,,,,,)+-- deriveGeneric ''(,,,,,,)+-- deriveGeneric ''(,,,,,,,)+-- deriveGeneric ''(,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,) -- 10+-- deriveGeneric ''(,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,,) -- 15+-- deriveGeneric ''(,,,,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,) -- 20+-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,) -- 25+-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)+-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30+-- deriveGeneric ''[]++deriveGeneric1 ''Maybe+deriveGeneric1 ''Either+deriveGeneric1 ''(,) -- 2+deriveGeneric1 ''(,,)+deriveGeneric1 ''(,,,)+deriveGeneric1 ''(,,,,) -- 5+deriveGeneric1 ''(,,,,,)+deriveGeneric1 ''(,,,,,,)+deriveGeneric1 ''(,,,,,,,)+deriveGeneric1 ''(,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,) -- 10+deriveGeneric1 ''(,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,,) -- 15+deriveGeneric1 ''(,,,,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,) -- 20+deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,,) -- 25+deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)+deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30+deriveGeneric1 ''[]++-- Other types from base:++-- From Control.Exception:+deriveGeneric ''IOException+deriveGeneric ''ArithException+deriveGeneric ''ArrayException+deriveGeneric ''AssertionFailed+deriveGeneric ''AsyncException+deriveGeneric ''NonTermination+deriveGeneric ''NestedAtomically+deriveGeneric ''BlockedIndefinitelyOnMVar+deriveGeneric ''BlockedIndefinitelyOnSTM+deriveGeneric ''AllocationLimitExceeded+deriveGeneric ''Deadlock+deriveGeneric ''NoMethodError+deriveGeneric ''PatternMatchFail+deriveGeneric ''RecConError+deriveGeneric ''RecSelError+deriveGeneric ''RecUpdError+deriveGeneric ''ErrorCall+deriveGeneric ''TypeError+deriveGeneric ''MaskingState++-- From Data.Char:+deriveGeneric ''GeneralCategory++-- From Data.Complex:+deriveGeneric ''Complex++-- From Data.Data:+deriveGeneric ''DataRep+deriveGeneric ''Fixity+deriveGeneric ''ConstrRep++-- From Data.Fixed:+deriveGeneric ''Fixed+deriveGeneric ''E0+deriveGeneric ''E1+deriveGeneric ''E2+deriveGeneric ''E3+deriveGeneric ''E6+deriveGeneric ''E9+deriveGeneric ''E12++-- From Data.Functor.Compose+deriveGeneric ''Compose+deriveGeneric1 ''Compose++-- From Data.Functor.Const+deriveGeneric ''Data.Functor.Const.Const+deriveGeneric1 ''Data.Functor.Const.Const++-- From Data.Functor.Identity+deriveGeneric ''Identity+deriveGeneric1 ''Identity++-- From Data.Functor.Product+deriveGeneric ''Product+deriveGeneric1 ''Product++-- From Data.Functor.Sum+deriveGeneric ''Sum+deriveGeneric1 ''Sum++-- From Data.List.NonEmpty+deriveGeneric ''NonEmpty+deriveGeneric1 ''NonEmpty++-- From Data.Monoid:+deriveGeneric ''Data.Monoid.Dual+deriveGeneric ''Data.Monoid.Endo+deriveGeneric ''Data.Monoid.All+deriveGeneric ''Data.Monoid.Any+deriveGeneric ''Data.Monoid.Sum+deriveGeneric ''Data.Monoid.Product+deriveGeneric ''Data.Monoid.First+deriveGeneric ''Data.Monoid.Last+deriveGeneric ''Data.Monoid.Alt++deriveGeneric1 ''Data.Monoid.Dual+-- deriveGeneric1 ''Data.Monoid.Endo+deriveGeneric1 ''Data.Monoid.Sum+deriveGeneric1 ''Data.Monoid.Product+deriveGeneric1 ''Data.Monoid.First+deriveGeneric1 ''Data.Monoid.Last+deriveGeneric1 ''Data.Monoid.Alt++-- From Data.Ord:+deriveGeneric ''Down+deriveGeneric1 ''Down++-- From Data.Proxy:+deriveGeneric ''Proxy+deriveGeneric1 ''Proxy++-- From Data.Semigroup:+deriveGeneric ''Data.Semigroup.Min+deriveGeneric ''Data.Semigroup.Max+deriveGeneric ''Data.Semigroup.First+deriveGeneric ''Data.Semigroup.Last+deriveGeneric ''Data.Semigroup.WrappedMonoid+deriveGeneric ''Data.Semigroup.Option+deriveGeneric ''Data.Semigroup.Arg++deriveGeneric1 ''Data.Semigroup.Min+deriveGeneric1 ''Data.Semigroup.Max+deriveGeneric1 ''Data.Semigroup.First+deriveGeneric1 ''Data.Semigroup.Last+deriveGeneric1 ''Data.Semigroup.WrappedMonoid+deriveGeneric1 ''Data.Semigroup.Option+deriveGeneric1 ''Data.Semigroup.Arg++-- From Data.Version:+deriveGeneric ''Version++-- From Data.Void:+deriveGeneric ''Void++-- From Foreign.C.Error:+deriveGeneric ''Errno++-- From Foreign.C.Types:+deriveGeneric ''CChar+deriveGeneric ''CSChar+deriveGeneric ''CUChar+deriveGeneric ''CShort+deriveGeneric ''CUShort+deriveGeneric ''CInt+deriveGeneric ''CUInt+deriveGeneric ''CLong+deriveGeneric ''CULong+deriveGeneric ''CPtrdiff+deriveGeneric ''CSize+deriveGeneric ''CWchar+deriveGeneric ''CSigAtomic+deriveGeneric ''CLLong+deriveGeneric ''CULLong+deriveGeneric ''CIntPtr+deriveGeneric ''CUIntPtr+deriveGeneric ''CIntMax+deriveGeneric ''CUIntMax+deriveGeneric ''CClock+deriveGeneric ''CTime+deriveGeneric ''CUSeconds+deriveGeneric ''CSUSeconds+deriveGeneric ''CFloat+deriveGeneric ''CDouble++-- From GHC.ByteOrder:+deriveGeneric ''ByteOrder++-- From GHC.Conc:+deriveGeneric ''ThreadStatus+deriveGeneric ''BlockReason++-- From GHC.ExecutionStack:+deriveGeneric ''Location+deriveGeneric ''SrcLoc++-- From GHC.Exts:+deriveGeneric ''RuntimeRep+deriveGeneric ''VecCount+deriveGeneric ''VecElem++-- From GHC.Generics:+deriveGeneric ''GHC.Generics.K1+deriveGeneric ''GHC.Generics.U1+deriveGeneric ''GHC.Generics.V1+deriveGeneric ''GHC.Generics.Par1+deriveGeneric ''GHC.Generics.M1+deriveGeneric ''GHC.Generics.R+deriveGeneric ''GHC.Generics.S+deriveGeneric ''GHC.Generics.D+deriveGeneric ''GHC.Generics.C+deriveGeneric ''(GHC.Generics.:*:)+deriveGeneric ''(GHC.Generics.:+:)+deriveGeneric ''(GHC.Generics.:.:)+deriveGeneric ''GHC.Generics.Associativity+deriveGeneric ''GHC.Generics.DecidedStrictness+deriveGeneric ''GHC.Generics.SourceStrictness+deriveGeneric ''GHC.Generics.SourceUnpackedness+deriveGeneric ''GHC.Generics.Fixity++-- From GHC.IO.Buffer:+deriveGeneric ''Buffer+deriveGeneric ''BufferState++-- From GHC.IO.Device:+deriveGeneric ''IODeviceType++-- From GHC.IO.Encoding:+deriveGeneric ''BufferCodec+deriveGeneric ''CodingProgress++-- From GHC.IO.Encoding.Failure:+deriveGeneric ''CodingFailureMode++-- From GHC.Fingerprint+deriveGeneric ''Fingerprint++-- From GHC.Float+deriveGeneric ''FFFormat++-- From GHC.IO.Exception:+deriveGeneric ''FixIOException+deriveGeneric ''IOErrorType++-- From GHC.IO.Handle:+deriveGeneric ''HandlePosn+deriveGeneric ''LockMode++-- From GHC.RTS.Flags:+deriveGeneric ''RTSFlags+deriveGeneric ''GiveGCStats+deriveGeneric ''GCFlags+deriveGeneric ''ConcFlags+deriveGeneric ''MiscFlags+deriveGeneric ''DebugFlags+deriveGeneric ''DoCostCentres+deriveGeneric ''CCFlags+deriveGeneric ''DoHeapProfile+deriveGeneric ''ProfFlags+deriveGeneric ''DoTrace+deriveGeneric ''TraceFlags+deriveGeneric ''TickyFlags+deriveGeneric ''ParFlags++-- From GHC.Stack:+deriveGeneric ''GHC.Stack.SrcLoc+deriveGeneric ''GHC.Stack.CallStack++-- From GHC.StaticPtr:+deriveGeneric ''StaticPtrInfo++-- From GHC.Stats:+deriveGeneric ''RTSStats+deriveGeneric ''GCDetails++-- From System.Console.GetOpt:++deriveGeneric ''ArgOrder+deriveGeneric ''OptDescr+deriveGeneric ''ArgDescr++-- From System.Exit:++deriveGeneric ''ExitCode++-- From System.IO:++deriveGeneric ''IOMode+deriveGeneric ''BufferMode+deriveGeneric ''SeekMode+deriveGeneric ''Newline+deriveGeneric ''NewlineMode++-- From Text.Printf:++deriveGeneric ''FieldFormat+deriveGeneric ''FormatAdjustment+deriveGeneric ''FormatSign+deriveGeneric ''FormatParse++-- From Text.Read.Lex:++deriveGeneric ''Lexeme+deriveGeneric ''Number++-- Abstract / primitive datatypes (we don't derive Generic for these):+--+-- Ratio+-- Integer+-- ThreadId+-- Chan+-- MVar+-- QSem+-- QSemN+-- DataType+-- Dynamic+-- IORef+-- TypeRep+-- TyCon+-- TypeRepKey+-- KProxy -- not abstract, but intended for kind-level use+-- STRef+-- Unique+-- ForeignPtr+-- CFile+-- CFpos+-- CJmpBuf+-- Pool+-- Ptr+-- FunPtr+-- IntPtr+-- WordPtr+-- StablePtr+-- Char+-- Double+-- Float+-- Int+-- Int8+-- Int16+-- Int32+-- Int64+-- Word+-- Word8+-- Word16+-- Word32+-- Word64+-- IO+-- ST+-- (->)+-- RealWorld+-- Handle+-- HandlePosn+-- TextEncoding+-- StableName+-- Weak+-- ReadP+-- ReadPrec+-- STM+-- TVar+-- Natural+-- Event+-- EventManager+-- CostCentre+-- CostCentreStack+--+-- Datatypes we cannot currently handle:+--+-- SomeException+-- SomeAsyncException+-- Handler+-- Coercion+-- (:~:)
+ src/Staged/GHC/Generics/Internal.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskellQuotes #-}+module Staged.GHC.Generics.Internal (sapply) where++import Language.Haskell.TH (Code, Quote)++sapply :: Quote q => Code q (a -> b) -> Code q a -> Code q b+sapply cf cx = [|| $$cf $$cx ||]
+ src/Staged/GHC/Generics/TH.hs view
@@ -0,0 +1,642 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+module Staged.GHC.Generics.TH (+ deriveGeneric,+ deriveGeneric1,+) where++import Control.Monad ((>=>), unless, when, forM)++-- template-haskell+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++-- names+import Staged.GHC.Generics.TH.Names+import Staged.GHC.Generics.Internal (sapply)++-- th-abstraction+import Language.Haskell.TH.Datatype++-- from generic-deriving+import Generics.Deriving.TH.Internal+import Generics.Deriving.TH.Post4_9+import Generics.Deriving.TH+ (KindSigOptions, Options (..), RepOptions (..), defaultOptions)++-- th-lift+import Language.Haskell.TH.Lift ()++import qualified Data.Map as Map (fromList)++-- | Derive 'Staged.GHC.Generics.Generic' using Template Haskell.+deriveGeneric :: Name -> Q [Dec]+deriveGeneric n = do+ deriveInstCommon staged_genericTypeName staged_repTypeName Generic staged_fromValName staged_toValName defaultOptions n++-- | Derive 'Staged.GHC.Generics.Generic1' using Template Haskell.+deriveGeneric1 :: Name -> Q [Dec]+deriveGeneric1 n = do+ deriveInstCommon staged_generic1TypeName staged_rep1TypeName Generic1 staged_fromVal1Name staged_toVal1Name defaultOptions n++deriveInstCommon :: Name+ -> Name+ -> GenericClass+ -> Name+ -> Name+ -> Options+ -> Name+ -> Q [Dec]+deriveInstCommon genericName repName gClass fromName toName opts n = do+ i <- reifyDataInfo n++ let (name, instTys, cons, dv) = either error id i+ useKindSigs = kindSigOptions opts++ -- See Note [Forcing buildTypeInstance]+ !(origTy, origKind) <- buildTypeInstance gClass useKindSigs name instTys+ tyInsRHS <- if repOptions opts == InlineRep+ then makeRepInline gClass dv name instTys cons origTy+ else makeRepTySynApp gClass dv name origTy++ let origSigTy = if useKindSigs+ then SigT origTy origKind+ else origTy+ tyIns <- tySynInstDCompat repName+ Nothing+ [return origSigTy] (return tyInsRHS)++ let ecOptions = emptyCaseOptions opts+ mkBody maker = [clause [] (normalB $+ mkCaseExp gClass ecOptions name instTys cons maker) []]+ tcs = mkBody mkTo++ fcs' = do+ val <- newName "val"+ k <- newName "_kont" -- avoids unused warning+ lamE [varP val, varP k] $+ [| unsafeCodeCoerce |] `appE` foldl appE [| caseE |]+ [ [| unTypeCode |] `appE` varE val+ , mkFrom (varE k) gClass ecOptions 1 1 name instTys cons+ ]++ fcs = [ clause [] (normalB fcs') []]++ fmap (:[]) $+ instanceD (cxt []) (conT genericName `appT` return origSigTy)+ [return tyIns, funD fromName fcs, funD toName tcs]++-------------------------------------------------------------------------------+-- Internal+-------------------------------------------------------------------------------++-- For the given Types, deduces the instance type (and kind) to use for a+-- Generic(1) instance. Coming up with the instance type isn't as simple as+-- dropping the last types, as you need to be wary of kinds being instantiated+-- with *.+-- See Note [Type inference in derived instances]+buildTypeInstance :: GenericClass+ -- ^ Generic or Generic1+ -> KindSigOptions+ -- ^ Whether or not to use explicit kind signatures in the instance type+ -> Name+ -- ^ The type constructor or data family name+ -> [Type]+ -- ^ The types to instantiate the instance with+ -> Q (Type, Kind)+buildTypeInstance gClass useKindSigs tyConName varTysOrig = do+ -- Make sure to expand through type/kind synonyms! Otherwise, the+ -- eta-reduction check might get tripped up over type variables in a+ -- synonym that are actually dropped.+ -- (See GHC Trac #11416 for a scenario where this actually happened.)+ varTysExp <- mapM resolveTypeSynonyms varTysOrig++ let remainingLength :: Int+ remainingLength = length varTysOrig - fromEnum gClass++ droppedTysExp :: [Type]+ droppedTysExp = drop remainingLength varTysExp++ droppedStarKindStati :: [StarKindStatus]+ droppedStarKindStati = map canRealizeKindStar droppedTysExp++ -- Check there are enough types to drop and that all of them are either of+ -- kind * or kind k (for some kind variable k). If not, throw an error.+ when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $+ derivingKindError tyConName++ -- Substitute kind * for any dropped kind variables+ let varTysExpSubst :: [Type]+-- See Note [Generic1 is polykinded in base-4.10]+#if MIN_VERSION_base(4,10,0)+ varTysExpSubst = varTysExp+#else+ varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp++ droppedKindVarNames :: [Name]+ droppedKindVarNames = catKindVarNames droppedStarKindStati+#endif++ let remainingTysExpSubst, droppedTysExpSubst :: [Type]+ (remainingTysExpSubst, droppedTysExpSubst) =+ splitAt remainingLength varTysExpSubst++-- See Note [Generic1 is polykinded in base-4.10]+#if !(MIN_VERSION_base(4,10,0))+ -- If any of the dropped types were polykinded, ensure that there are of+ -- kind * after substituting * for the dropped kind variables. If not,+ -- throw an error.+ unless (all hasKindStar droppedTysExpSubst) $+ derivingKindError tyConName+#endif++ -- We now substitute all of the specialized-to-* kind variable names+ -- with *, but in the original types, not the synonym-expanded types. The reason+ -- we do this is a superficial one: we want the derived instance to resemble+ -- the datatype written in source code as closely as possible. For example,+ -- for the following data family instance:+ --+ -- data family Fam a+ -- newtype instance Fam String = Fam String+ --+ -- We'd want to generate the instance:+ --+ -- instance C (Fam String)+ --+ -- Not:+ --+ -- instance C (Fam [Char])+ let varTysOrigSubst :: [Type]+ varTysOrigSubst =+-- See Note [Generic1 is polykinded in base-4.10]+#if MIN_VERSION_base(4,10,0)+ id+#else+ map (substNamesWithKindStar droppedKindVarNames)+#endif+ $ varTysOrig++ remainingTysOrigSubst, droppedTysOrigSubst :: [Type]+ (remainingTysOrigSubst, droppedTysOrigSubst) =+ splitAt remainingLength varTysOrigSubst++ remainingTysOrigSubst' :: [Type]+ -- See Note [Kind signatures in derived instances] for an explanation+ -- of the useKindSigs check.+ remainingTysOrigSubst' =+ if useKindSigs+ then remainingTysOrigSubst+ else map unSigT remainingTysOrigSubst++ instanceType :: Type+ instanceType = applyTyToTys (ConT tyConName) remainingTysOrigSubst'++ -- See Note [Kind signatures in derived instances]+ instanceKind :: Kind+ instanceKind = makeFunKind (map typeKind droppedTysOrigSubst) starK++ -- Ensure the dropped types can be safely eta-reduced. Otherwise,+ -- throw an error.+ unless (canEtaReduce remainingTysExpSubst droppedTysExpSubst) $+ etaReductionError instanceType+ return (instanceType, instanceKind)++makeRepInline :: GenericClass+ -> DatatypeVariant_+ -> Name+ -> [Type]+ -> [ConstructorInfo]+ -> Type+ -> Q Type+makeRepInline gClass dv name instTys cons ty = do+ let instVars = freeVariablesWellScoped [ty]+ (tySynVars, gk) = genericKind gClass instTys++ typeSubst :: TypeSubst+ typeSubst = Map.fromList $+ zip (map tvName tySynVars)+ (map (VarT . tvName) instVars)++ repType gk dv name typeSubst cons++genRepName :: GenericClass -> DatatypeVariant_+ -> Name -> Name+genRepName gClass dv n+ = mkName+ . showsDatatypeVariant dv+ . (("Rep" ++ show (fromEnum gClass)) ++)+ . ((showNameQual n ++ "_") ++)+ . sanitizeName+ $ nameBase n++repType :: GenericKind+ -> DatatypeVariant_+ -> Name+ -> TypeSubst+ -> [ConstructorInfo]+ -> Q Type+repType gk dv dt typeSubst cs =+ conT d2TypeName `appT` mkMetaDataType dv dt `appT`+ foldBal sum' (conT v2TypeName) (map (repCon gk dv dt typeSubst) cs)+ where+ sum' :: Q Type -> Q Type -> Q Type+ sum' a b = conT staged_sumTypeName `appT` a `appT` b++repCon :: GenericKind+ -> DatatypeVariant_+ -> Name+ -> TypeSubst+ -> ConstructorInfo+ -> Q Type+repCon gk dv dt typeSubst+ (ConstructorInfo { constructorName = n+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorStrictness = bangs+ , constructorFields = ts+ , constructorVariant = cv+ }) = do+ checkExistentialContext n vars ctxt+ let mbSelNames = case cv of+ NormalConstructor -> Nothing+ InfixConstructor -> Nothing+ RecordConstructor selNames -> Just selNames+ isRecord = case cv of+ NormalConstructor -> False+ InfixConstructor -> False+ RecordConstructor _ -> True+ isInfix = case cv of+ NormalConstructor -> False+ InfixConstructor -> True+ RecordConstructor _ -> False+ ssis <- reifySelStrictInfo n bangs+ repConWith gk dv dt n typeSubst mbSelNames ssis ts isRecord isInfix++repConWith :: GenericKind+ -> DatatypeVariant_+ -> Name+ -> Name+ -> TypeSubst+ -> Maybe [Name]+ -> [SelStrictInfo]+ -> [Type]+ -> Bool+ -> Bool+ -> Q Type+repConWith gk dv dt n typeSubst mbSelNames ssis ts isRecord isInfix = do+ let structureType :: Q Type+ structureType = foldBal prodT (conT u2TypeName) f++ f :: [Q Type]+ f = case mbSelNames of+ Just selNames -> zipWith3 (repField gk dv dt n typeSubst . Just)+ selNames ssis ts+ Nothing -> zipWith (repField gk dv dt n typeSubst Nothing)+ ssis ts++ conT c2TypeName+ `appT` mkMetaConsType dv dt n isRecord isInfix+ `appT` structureType++prodT :: Q Type -> Q Type -> Q Type+prodT a b = conT staged_productTypeName `appT` a `appT` b++repField :: GenericKind+ -> DatatypeVariant_+ -> Name+ -> Name+ -> TypeSubst+ -> Maybe Name+ -> SelStrictInfo+ -> Type+ -> Q Type+repField gk dv dt ns typeSubst mbF ssi t =+ conT s2TypeName+ `appT` mkMetaSelType dv dt ns mbF ssi+ `appT` (repFieldArg gk False =<< resolveTypeSynonyms t'')+ where+ -- See Note [Generic1 is polykinded in base-4.10]+ t', t'' :: Type+ t' = case gk of+ Gen1 _ (Just _kvName) ->+#if MIN_VERSION_base(4,10,0)+ t+#else+ substNameWithKind _kvName starK t+#endif+ _ -> t+ t'' = applySubstitution typeSubst t'++repFieldArg :: GenericKind -> Bool -> Type -> Q Type+repFieldArg _ _ ForallT{} = rankNError+repFieldArg gk inPar (SigT t _) = repFieldArg gk inPar t+repFieldArg Gen0 _ t = boxT t+repFieldArg (Gen1 name _) _ (VarT t) | t == name = conT par2TypeName+repFieldArg gk@(Gen1 name _) inPar t = do+ let tyHead:tyArgs = unapplyTy t+ numLastArgs = min 1 $ length tyArgs+ (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs+ k2Type = boxT t+ phiType = return $ applyTyToTys tyHead lhsArgs++ let inspectTy :: Type -> Q Type+ inspectTy (VarT a)+ | a == name+ = if inPar+ then phiType+ else conT staged_appTypeName `appT` conT par2TypeName `appT` phiType+ inspectTy (SigT ty _) = inspectTy ty+ inspectTy beta+ | not (ground beta name)+ = conT staged_appTypeName+ `appT` (conT staged_appTypeName `appT` conT par2TypeName `appT` phiType)+ `appT` repFieldArg gk True beta+ inspectTy _ = k2Type++ itf <- isTyFamily tyHead+ if any (not . (`ground` name)) lhsArgs+ || any (not . (`ground` name)) tyArgs && itf+ then outOfPlaceTyVarError+ else case rhsArgs of+ [] -> k2Type+ ty:_ -> inspectTy ty++boxT :: Type -> Q Type+boxT ty = case unboxedRepNames ty of+ Just (boxTyName, _, _) -> conT boxTyName+ Nothing -> conT k2TypeName `appT` return ty++unboxedRepNames :: Type -> Maybe (Name, Name, Name)+unboxedRepNames ty+ | ty == ConT addrHashTypeName = Just (uAddrTypeName, uAddrDataName, uAddrHashValName)+ | ty == ConT charHashTypeName = Just (uCharTypeName, uCharDataName, uCharHashValName)+ | ty == ConT doubleHashTypeName = Just (uDoubleTypeName, uDoubleDataName, uDoubleHashValName)+ | ty == ConT floatHashTypeName = Just (uFloatTypeName, uFloatDataName, uFloatHashValName)+ | ty == ConT intHashTypeName = Just (uIntTypeName, uIntDataName, uIntHashValName)+ | ty == ConT wordHashTypeName = Just (uWordTypeName, uWordDataName, uWordHashValName)+ | otherwise = Nothing++makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name+ -> Type -> Q Type+makeRepTySynApp gClass dv name ty =+ -- Here, we figure out the distinct type variables (in order from left-to-right)+ -- of the LHS of the Rep(1) instance. We call unKindedTV because the kind+ -- inferencer can figure out the kinds perfectly well, so we don't need to+ -- give anything here explicit kind signatures.+ let instTvbs = map unKindedTV $ freeVariablesWellScoped [ty]+ in return $ applyTyToTvbs (genRepName gClass dv name) instTvbs++mkCaseExp+ :: GenericClass -> EmptyCaseOptions -> Name -> [Type] -> [ConstructorInfo]+ -> (GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]+ -> [ConstructorInfo] -> Q Match)+ -> Q Exp+mkCaseExp gClass ecOptions dt instTys cs matchmaker = do+ val <- newName "val"+ lam1E (varP val) $ caseE (varE val) [matchmaker gClass ecOptions 1 1 dt instTys cs]++-- | 'True' if generated code for empty data types should use the @EmptyCase@+-- extension, 'False' otherwise. This has no effect on GHCs before 7.8, since+-- @EmptyCase@ is only available in 7.8 or later.+type EmptyCaseOptions = Bool++-------------------------------------------------------------------------------+-- mkTo+-------------------------------------------------------------------------------++mkTo :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]+ -> [ConstructorInfo] -> Q Match+mkTo gClass ecOptions m i dt instTys cs = do+ y <- newName "y"+ match (conP m2DataName [varP y])+ (normalB $ caseE (varE y) cases)+ []+ where+ cases = case cs of+ [] -> errorTo ecOptions dt+ _ -> zipWith (toCon gk wrapP (length cs)) [1..] cs+ wrapP p = lrP i m p+ (_, gk) = genericKind gClass instTys+++toCon :: GenericKind -> (Q Pat -> Q Pat) -> Int -> Int+ -> ConstructorInfo -> Q Match+toCon gk wrap m i+ (ConstructorInfo { constructorName = cn+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorFields = ts+ }) = do+ checkExistentialContext cn vars ctxt+ fNames <- newNameList "f" $ length ts+ match (wrap $ lrP i m $ conP m2DataName+ [foldBal prod (conP u2DataName []) (zipWith (toField gk) fNames ts)])+ (normalB $ foldl+ (\f x -> [| sapply $f $x |])+ ([| unsafeCodeCoerce |] `appE` ([| conE |] `appE` lift cn))+ (zipWith (\nr -> resolveTypeSynonyms >=> toConUnwC gk nr)+ fNames ts)) []+ where prod x y = conP staged_productDataName [x,y]++toConUnwC :: GenericKind -> Name -> Type -> Q Exp+toConUnwC Gen0 nr _ = varE nr+toConUnwC (Gen1 name _) nr t = unwC t False name nr++toField :: GenericKind -> Name -> Type -> Q Pat+toField gk nr t = conP m2DataName [toFieldWrap gk nr t]++toFieldWrap :: GenericKind -> Name -> Type -> Q Pat+toFieldWrap Gen0 nr t = conP (boxRepName t) [varP nr]+toFieldWrap Gen1{} nr _ = varP nr++unwC :: Type -> Bool -> Name -> Name -> Q Exp+unwC (SigT t _) inPar name nr = unwC t inPar name nr+unwC (VarT t) _inPar name nr | t == name = varE unPar2ValName `appE` varE nr+unwC t inPar name nr+ | ground t name = varE (unboxRepName t) `appE` varE nr+ | otherwise = do+ let tyHead:tyArgs = unapplyTy t+ numLastArgs = min 1 $ length tyArgs+ (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs++ inspectTy :: Type -> Q Exp+ inspectTy ForallT{} = rankNError+ inspectTy (SigT ty _) = inspectTy ty+ inspectTy (VarT a)+ | a == name+ = if inPar+ then varE unAppValName `appE` varE nr+ else varE unPar2ValName `appE` (varE unAppValName `appE` varE nr)+ inspectTy beta+ = varE unPar2ValName `appE` (varE unAppValName `appE` unwC beta True name nr)++ itf <- isTyFamily tyHead+ if any (not . (`ground` name)) lhsArgs+ || any (not . (`ground` name)) tyArgs && itf+ then outOfPlaceTyVarError+ else case rhsArgs of+ [] -> varE (unboxRepName t) `appE` varE nr+ ty:_ -> inspectTy ty++unboxRepName :: Type -> Name+unboxRepName = maybe unK2ValName trd3 . unboxedRepNames++boxRepName :: Type -> Name+boxRepName = maybe k2DataName snd3 . unboxedRepNames++-------------------------------------------------------------------------------+-- mkFrom+-------------------------------------------------------------------------------++mkFrom :: Q Exp+ -> GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]+ -> [ConstructorInfo] -> Q Exp+mkFrom kont gClass ecOptions m i dt instTys cs = do+ -- y <- newName "y"+ listE cases+ -- match (varP y)+ -- (normalB $ conE m2DataName `appE` caseE (varE y) cases)+ -- []+ where+ cases :: [ExpQ]+ cases = case cs of+ [] -> errorFrom ecOptions dt+ _ -> zipWith (fromCon kont gk wrapE (length cs)) [1..] cs+ wrapE e = lrE i m e+ (_, gk) = genericKind gClass instTys++errorFrom :: EmptyCaseOptions -> Name -> [ExpQ]+errorFrom _useEmptyCase _dt = []+{- TODO:+ | useEmptyCase && ghc7'8OrLater+ = []+ | otherwise+ = [do z <- newName "z"+ match+ (varP z)+ (normalB $+ appE (varE seqValName) (varE z) `appE`+ appE (varE errorValName)+ (stringE $ "No generic representation for empty datatype "+ ++ nameBase dt))+ []]+-}++fromCon :: Q Exp+ -> GenericKind -> (Q Exp -> Q Exp) -> Int -> Int+ -> ConstructorInfo -> Q Exp+fromCon kont gk wrap m i+ (ConstructorInfo { constructorName = cn+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorFields = ts+ }) = do+ checkExistentialContext cn vars ctxt+ fNames <- newNameList' "f" $ length ts++ let fNameExps :: [ExpQ]+ fNameExps =+ [ [| unsafeCodeCoerce (varE $(varE fName)) |]+ | (fName, _) <- fNames+ ]++ let kontArg :: ExpQ+ kontArg = wrap $ lrE i m $ conE m2DataName `appE`+ foldBal prodE (conE u2DataName) (zipWith (fromField gk) fNameExps ts)++ -- we create a do block which makes new variables.+ let bindNewNames = [ bindS (varP v) [| newName $(stringE s) |] | (v, s) <- fNames ]++ doE $ bindNewNames ++++ -- match (conP cn (map varP fNames))+ -- (normalB $ wrap $ lrE i m $ conE m2DataName `appE`+ -- foldBal prodE (conE u2DataName) (zipWith (fromField gk) fNames ts)) []+ [ noBindS $ foldl appE [| match |]+ [ foldl appE [| conP |]+ [ lift cn+ , listE [ [| varP |] `appE` varE fName | (fName, _) <- fNames ]+ ]+ , [| normalB (unTypeCode ($kont $(conE m2DataName `appE` kontArg))) |]+ , listE []+ ]+ ]++newNameList' :: String -> Int -> Q [(Name, String)]+newNameList' prefix n = forM [1..n] $ \i -> do+ let s = prefix ++ show i+ n' <- newName s+ return (n', s)++prodE :: Q Exp -> Q Exp -> Q Exp+prodE x y = conE staged_productDataName `appE` x `appE` y++fromField :: GenericKind -> Q Exp -> Type -> Q Exp+fromField gk nr t = conE m2DataName `appE` (fromFieldWrap gk nr =<< resolveTypeSynonyms t)++fromFieldWrap :: GenericKind -> Q Exp -> Type -> Q Exp+fromFieldWrap _ _ ForallT{} = rankNError+fromFieldWrap gk nr (SigT t _) = fromFieldWrap gk nr t+fromFieldWrap Gen0 nr t = conE (boxRepName t) `appE` nr+fromFieldWrap (Gen1 name _) nr t = wC t name nr++wC :: Type -> Name -> Q Exp -> Q Exp+wC (VarT t) name nr | t == name = conE par2DataName `appE` nr+wC t name nr+ | ground t name = conE (boxRepName t) `appE` nr+ | otherwise = do+ let tyHead:tyArgs = unapplyTy t+ numLastArgs = min 1 $ length tyArgs+ (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs++ inspectTy :: Type -> Q Exp+ inspectTy ForallT{} = rankNError+ inspectTy (SigT ty _) = inspectTy ty+ inspectTy (VarT a)+ | a == name+ = conE appDataName `appE` (conE par2DataName `appE` nr)+ inspectTy beta =+ conE appDataName `appE` wC beta name nr++ itf <- isTyFamily tyHead+ if any (not . (`ground` name)) lhsArgs+ || any (not . (`ground` name)) tyArgs && itf+ then outOfPlaceTyVarError+ else case rhsArgs of+ [] -> conE (boxRepName t) `appE` nr+ ty:_ -> inspectTy ty++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++errorTo :: EmptyCaseOptions -> Name -> [Q Match]+errorTo useEmptyCase dt+ | useEmptyCase+ = []+ | otherwise+ = [do z <- newName "z"+ match+ (varP z)+ (normalB $+ appE (varE seqValName) (varE z) `appE`+ appE (varE errorValName)+ (stringE $ "No values for empty datatype " ++ nameBase dt))+ []]++lrP :: Int -> Int -> (Q Pat -> Q Pat)+lrP i n p+ | n == 0 = fail "lrP: impossible"+ | n == 1 = p+ | i <= div n 2 = conP l2DataName [lrP i (div n 2) p]+ | otherwise = conP r2DataName [lrP (i-m) (n-m) p]+ where m = div n 2++lrE :: Int -> Int -> (Q Exp -> Q Exp)+lrE i n e+ | n == 0 = fail "lrE: impossible"+ | n == 1 = e+ | i <= div n 2 = conE l2DataName `appE` lrE i (div n 2) e+ | otherwise = conE r2DataName `appE` lrE (i-m) (n-m) e+ where m = div n 2
+ src/Staged/GHC/Generics/TH/Names.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TemplateHaskellQuotes #-}+module Staged.GHC.Generics.TH.Names where++import Staged.GHC.Generics.Types++import Language.Haskell.TH.Syntax (Name)++staged_genericTypeName :: Name+staged_genericTypeName = ''Generic++staged_repTypeName :: Name+staged_repTypeName = ''Rep++staged_generic1TypeName :: Name+staged_generic1TypeName = ''Generic1++staged_rep1TypeName :: Name+staged_rep1TypeName = ''Rep1++c2TypeName :: Name+c2TypeName = ''C2++d2TypeName :: Name+d2TypeName = ''D2++s2TypeName :: Name+s2TypeName = ''S2++staged_productTypeName :: Name+staged_productTypeName = ''(:**:)++staged_sumTypeName :: Name+staged_sumTypeName = ''(:++:)++staged_appTypeName :: Name+staged_appTypeName = ''(:@@:)++appDataName :: Name+appDataName = 'App2++unAppValName :: Name+unAppValName = 'unApp2++u2TypeName :: Name+u2TypeName = ''U2++v2TypeName :: Name+v2TypeName = ''V2++par2TypeName :: Name+par2TypeName = ''Par2++par2DataName :: Name+par2DataName = 'Par2++unPar2ValName :: Name+unPar2ValName = 'unPar2++k2TypeName :: Name+k2TypeName = ''K2++staged_toValName :: Name+staged_toValName = 'to++staged_fromValName :: Name+staged_fromValName = 'from++staged_toVal1Name :: Name+staged_toVal1Name = 'to1++staged_fromVal1Name :: Name+staged_fromVal1Name = 'from1++k2DataName :: Name+k2DataName = 'K2++unK2ValName :: Name+unK2ValName = 'unK2++l2DataName :: Name+l2DataName = 'L2++m2DataName :: Name+m2DataName = 'M2++staged_productDataName :: Name+staged_productDataName = '(:**:)++r2DataName :: Name+r2DataName = 'R2++u2DataName :: Name+u2DataName = 'U2
+ src/Staged/GHC/Generics/Types.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- For default Rep definition+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_HADDOCK --not-home #-}+module Staged.GHC.Generics.Types (+ -- * Generic representation types+ V2,+ U2 (..),+ M2 (..),+ K2 (..),+ Par2 (..),+ (:++:) (..),+ (:**:) (..),+ (:@@:) (..),+ -- * Synonyms for convenience+ D2, C2, S2,+ D, C, S,+ -- * Meta-information+ Datatype (..),+ Constructor (..),+ Selector (..),+ Fixity (..),+ FixityI (..),+ Associativity (..),+ SourceUnpackedness (..),+ SourceStrictness (..),+ DecidedStrictness (..),+ Meta (..),+ -- * Generic type classes+ Generic (..),+ Generic1 (..),+ -- * TH Types+ Code, Quote,+ -- * Utilities+ Translate,+) where++import Data.Kind (Type)+import GHC.Generics+ (Associativity (..), C, Constructor (..), D, Datatype (..),+ DecidedStrictness (..), Fixity (..), FixityI (..), Meta (..), R, S,+ Selector (..), SourceStrictness (..), SourceUnpackedness (..))+import GHC.TypeLits (ErrorMessage (..), TypeError)+import Language.Haskell.TH (Code, Quote)++import qualified GHC.Generics as GHC++-------------------------------------------------------------------------------+-- Combinators+-------------------------------------------------------------------------------++data V2 (q :: Type -> Type) (p :: k)++deriving instance Eq (V2 q p)+deriving instance Ord (V2 q p)+deriving instance Show (V2 q p)+deriving instance Read (V2 q p)++data U2 (q :: Type -> Type) (p :: k) = U2++deriving instance Eq (U2 q p)+deriving instance Ord (U2 q p)+deriving instance Show (U2 q p)+deriving instance Read (U2 q p)++newtype M2 (i :: Type) (c :: Meta) (f :: (Type -> Type) -> k -> Type) (q :: Type -> Type) (p :: k)+ = M2 { unM2 :: f q p }++deriving instance Eq (f q p) => Eq (M2 i c f q p)+deriving instance Ord (f q p) => Ord (M2 i c f q p)+deriving instance Show (f q p) => Show (M2 i c f q p)+deriving instance Read (f q p) => Read (M2 i c f q p)++newtype K2 c (q :: Type -> Type) (p :: k)+ = K2 { unK2 :: q c }++deriving instance Eq (q c) => Eq (K2 c q p)+deriving instance Ord (q c) => Ord (K2 c q p)+deriving instance Show (q c) => Show (K2 c q p)+deriving instance Read (q c) => Read (K2 c q p)++infixr 5 :++:+data ((f :: (Type -> Type) -> k -> Type) :++: (g :: (Type -> Type) -> k -> Type)) (q :: Type -> Type) (p :: k)+ = L2 (f q p)+ | R2 (g q p)++deriving instance (Eq (f q p), Eq (g q p)) => Eq ((f :++: g) q p)+deriving instance (Ord (f q p), Ord (g q p)) => Ord ((f :++: g) q p)+deriving instance (Show (f q p), Show (g q p)) => Show ((f :++: g) q p)+deriving instance (Read (f q p), Read (g q p)) => Read ((f :++: g) q p)++infixr 6 :**:+data ((f :: (Type -> Type) -> k -> Type) :**: (g :: (Type -> Type) -> k -> Type)) (q :: Type -> Type) (p :: k)+ = f q p :**: g q p++deriving instance (Eq (f q p), Eq (g q p)) => Eq ((f :**: g) q p)+deriving instance (Ord (f q p), Ord (g q p)) => Ord ((f :**: g) q p)+deriving instance (Show (f q p), Show (g q p)) => Show ((f :**: g) q p)+deriving instance (Read (f q p), Read (g q p)) => Read ((f :**: g) q p)++-- https://gitlab.haskell.org/ghc/ghc/-/issues/15969#note_164233 !!!+infixl 7 :@@:+newtype ((f :: (Type -> Type) -> k2 -> Type) :@@: (g :: k1 -> k2)) (q :: Type -> Type) (p :: k1)+ = App2 { unApp2 :: f q (g p) }++deriving instance Eq (f q (g p)) => Eq ((f :@@: g) q p)+deriving instance Ord (f q (g p)) => Ord ((f :@@: g) q p)+deriving instance Show (f q (g p)) => Show ((f :@@: g) q p)+deriving instance Read (f q (g p)) => Read ((f :@@: g) q p)++newtype Par2 (q :: Type -> Type) (p :: Type)+ = Par2 { unPar2 :: q p }++deriving instance Eq (q p) => Eq (Par2 q p)+deriving instance Ord (q p) => Ord (Par2 q p)+deriving instance Show (q p) => Show (Par2 q p)+deriving instance Read (q p) => Read (Par2 q p)++-------------------------------------------------------------------------------+-- Synonyms for convenience+-------------------------------------------------------------------------------++type D2 = M2 D+type C2 = M2 C+type S2 = M2 S++-------------------------------------------------------------------------------+-- Generic type class+-------------------------------------------------------------------------------++class Generic (a :: Type) where+ type Rep a :: (Type -> Type) -> Type -> Type+ type Rep a = Translate (GHC.Rep a)++ to :: Quote q => Rep a (Code q) x -> Code q a+ from :: Quote q => Code q a -> (Rep a (Code q) x -> Code q r) -> Code q r++class Generic1 (f :: k -> Type) where+ type Rep1 f :: (Type -> Type) -> k -> Type+ type Rep1 f = Translate (GHC.Rep1 f)++ to1 :: Quote q => Rep1 f (Code q) x -> Code q (f x)+ from1 :: Quote q => Code q (f x) -> (Rep1 f (Code q) x -> Code q r) -> Code q r++-------------------------------------------------------------------------------+-- Derive our Rep from GHC.Generics.Rep+-------------------------------------------------------------------------------++-- | Translate "GHC.Generics" 'GHC.Rep' type into our 'Rep' type.+type family Translate (f :: k -> Type) :: (Type -> Type) -> k -> Type where+ Translate (GHC.M1 i c f) = M2 i c (Translate f)+ Translate (GHC.K1 R c) = K2 c+ Translate (f GHC.:+: g) = Translate f :++: Translate g+ Translate (f GHC.:*: g) = Translate f :**: Translate g+ Translate (GHC.Rec1 f) = Par2 :@@: f+ Translate GHC.Par1 = Par2+ Translate GHC.U1 = U2+ Translate GHC.V1 = V2+ Translate (f GHC.:.: g) = TranslateComp (Par2 :@@: f) g+ Translate x = TypeError ('Text "Translate error: " ':<>: 'ShowType x)++type family TranslateComp (f :: (k -> Type) -> k1 -> Type) (g :: k2 -> k1) :: (Type -> Type) -> k -> Type where+ TranslateComp acc (f GHC.:.: g) = TranslateComp (acc :@@: f) g+ TranslateComp acc (GHC.Rec1 f) = acc :@@: f+ TranslateComp _ x = TypeError ('Text "Translate :.: error: " ':<>: 'ShowType x)++-------------------------------------------------------------------------------+-- Example instance(s)+-------------------------------------------------------------------------------++instance Generic Bool where+ -- type Rep Bool = D2 ('MetaData "Bool" "GHC.Types" "ghc-prim" 'False)+ -- (C2 ('MetaCons "False" 'PrefixI 'False) U2 :++:+ -- C2 ('MetaCons "True" 'PrefixI 'False) U2)++ to (M2 (L2 (M2 U2))) = [|| False ||]+ to (M2 (R2 (M2 U2))) = [|| True ||]++ from x k = [||+ case $$x of+ False -> $$(k (M2 (L2 (M2 U2))))+ True -> $$(k (M2 (R2 (M2 U2)))) ||]
+ staged-gg.cabal view
@@ -0,0 +1,59 @@+cabal-version: 2.2+name: staged-gg+version: 0.1+synopsis: GHC.Generics style staged generics+category: Staged, Generics+description:+ GHC.Generics style staged generics.+ .+ See https://www.andres-loeh.de/StagedSOP/ paper for description of+ @staged-sop@, which is staged version of @generics-sop@.+ The non @generics-sop@ specific parts+ like sections on Typed Template Haskell, and Type Template Haskell and Constraints,+ are applicable to @staged-gg@ as well.+ .+ This package is an /EXPERIMENTAL/ proof-of-concept.+ It works if you do not do anything fancy.+ Because of current GHC Typed Template Haskell limitations,+ quite simple things are "fancy".+ See https://github.com/phadej/staged-gg/tree/master/staged-gg-examples+ for examples what you can do regardless.++author: Oleg Grenrus, Andres Löh+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+license: BSD-3-Clause+license-file: LICENSE+tested-with: GHC ==9.0.1++source-repository head+ type: git+ location: https://github.com/phadej/staged-gg.git++library+ default-language: Haskell2010+ ghc-options: -Wall+ hs-source-dirs: src++ -- ghc-boot dependencies+ build-depends:+ , base ^>=4.15+ , containers ^>=0.6.4.1+ , template-haskell ^>=2.17.0.0++ build-depends:+ , generic-deriving ^>=1.14+ , th-abstraction ^>=0.4.2.0+ , th-lift ^>=0.8.2++ -- staged generics+ exposed-modules:+ Staged.GHC.Generics+ Staged.GHC.Generics.Instances+ Staged.GHC.Generics.TH+ Staged.GHC.Generics.Types++ other-modules:+ Generics.Deriving.TH.Internal+ Generics.Deriving.TH.Post4_9+ Staged.GHC.Generics.Internal+ Staged.GHC.Generics.TH.Names