diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/src/Generics/Deriving/TH/Internal.hs b/src/Generics/Deriving/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/TH/Internal.hs @@ -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. ) +-- 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" diff --git a/src/Generics/Deriving/TH/Post4_9.hs b/src/Generics/Deriving/TH/Post4_9.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/TH/Post4_9.hs @@ -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 [] diff --git a/src/Staged/GHC/Generics.hs b/src/Staged/GHC/Generics.hs new file mode 100644 --- /dev/null +++ b/src/Staged/GHC/Generics.hs @@ -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 diff --git a/src/Staged/GHC/Generics/Instances.hs b/src/Staged/GHC/Generics/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Staged/GHC/Generics/Instances.hs @@ -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 +-- (:~:) diff --git a/src/Staged/GHC/Generics/Internal.hs b/src/Staged/GHC/Generics/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Staged/GHC/Generics/Internal.hs @@ -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 ||] diff --git a/src/Staged/GHC/Generics/TH.hs b/src/Staged/GHC/Generics/TH.hs new file mode 100644 --- /dev/null +++ b/src/Staged/GHC/Generics/TH.hs @@ -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 diff --git a/src/Staged/GHC/Generics/TH/Names.hs b/src/Staged/GHC/Generics/TH/Names.hs new file mode 100644 --- /dev/null +++ b/src/Staged/GHC/Generics/TH/Names.hs @@ -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 diff --git a/src/Staged/GHC/Generics/Types.hs b/src/Staged/GHC/Generics/Types.hs new file mode 100644 --- /dev/null +++ b/src/Staged/GHC/Generics/Types.hs @@ -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)))) ||] diff --git a/staged-gg.cabal b/staged-gg.cabal new file mode 100644 --- /dev/null +++ b/staged-gg.cabal @@ -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 +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