diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 1.10.6 +* A new `base-4-9` Cabal flag was added to more easily facilitate installing + `generic-deriving` with manually installed versions of `template-haskell`. + # 1.10.5 * Apply an optimization to generated `to(1)`/`from(1)` instances that factors out common occurrences of `M1`. See diff --git a/examples/Examples.hs b/examples/Examples.hs --- a/examples/Examples.hs +++ b/examples/Examples.hs @@ -18,7 +18,7 @@ {-# LANGUAGE DeriveGeneric #-} #endif -#if __GLASGOW_HASKELL__ >= 711 +#if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE DataKinds #-} #endif diff --git a/generic-deriving.cabal b/generic-deriving.cabal --- a/generic-deriving.cabal +++ b/generic-deriving.cabal @@ -1,5 +1,5 @@ name: generic-deriving -version: 1.10.5 +version: 1.10.6 synopsis: Generic programming library for generalised deriving. description: @@ -30,7 +30,7 @@ , GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 - , GHC == 7.10.2 + , GHC == 7.10.3 , GHC == 8.0.1 extra-source-files: examples/Examples.hs , CHANGELOG.md @@ -40,6 +40,11 @@ type: git location: https://github.com/dreixel/generic-deriving +flag base-4-9 + description: Use base-4.9 or later. This version of base uses a + DataKinds-based encoding of GHC generics metadata. + default: True + library hs-source-dirs: src exposed-modules: Generics.Deriving @@ -62,15 +67,15 @@ other-modules: Generics.Deriving.Base.Internal Generics.Deriving.TH.Internal Paths_generic_deriving - if impl(ghc >= 7.11) - other-modules: Generics.Deriving.TH.Post711 + if flag(base-4-9) + build-depends: base >= 4.9 && < 5 + other-modules: Generics.Deriving.TH.Post4'9 else - other-modules: Generics.Deriving.TH.Pre711 + build-depends: base >= 4.3 && < 4.9 + other-modules: Generics.Deriving.TH.Pre4'9 - build-depends: base < 5 - , containers >= 0.1 && < 0.6 + build-depends: containers >= 0.1 && < 0.6 + , ghc-prim < 1 , template-haskell >= 2.4 && < 2.12 - if impl(ghc > 7.0) - build-depends: ghc-prim < 1 ghc-options: -Wall diff --git a/src/Generics/Deriving/Base.hs b/src/Generics/Deriving/Base.hs --- a/src/Generics/Deriving/Base.hs +++ b/src/Generics/Deriving/Base.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 +#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif diff --git a/src/Generics/Deriving/Base/Internal.hs b/src/Generics/Deriving/Base/Internal.hs --- a/src/Generics/Deriving/Base/Internal.hs +++ b/src/Generics/Deriving/Base/Internal.hs @@ -595,7 +595,7 @@ -- /TODO:/ Also clear up confusion about 'Rec0' and 'Rec1' not really indicating recursion. -- #endif -#if __GLASGOW_HASKELL__ < 701 +#if !(MIN_VERSION_base(4,4,0)) -- * Generic representation types V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) , (:+:)(..), (:*:)(..), (:.:)(..) @@ -614,14 +614,14 @@ #else module GHC.Generics, #endif -#if __GLASGOW_HASKELL__ < 711 +#if !(MIN_VERSION_base(4,9,0)) -- ** Unboxed representation types URec(..), UAddr, UChar, UDouble, UFloat, UInt, UWord #endif ) where -#if __GLASGOW_HASKELL__ >= 701 +#if MIN_VERSION_base(4,4,0) import GHC.Generics #else import Control.Applicative ( Alternative(..) ) @@ -633,7 +633,7 @@ import Text.Read ( Read(..), parens, readListDefault, readListPrecDefault ) #endif -#if __GLASGOW_HASKELL__ < 709 +#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ( Applicative(..) ) import Data.Foldable ( Foldable(..) ) import Data.Monoid ( Monoid(..) ) @@ -641,13 +641,13 @@ import Data.Word ( Word ) #endif -#if __GLASGOW_HASKELL__ < 711 +#if !(MIN_VERSION_base(4,9,0)) import Data.Typeable import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) import GHC.Ptr ( Ptr ) #endif -#if __GLASGOW_HASKELL__ < 701 +#if !(MIN_VERSION_base(4,4,0)) -------------------------------------------------------------------------------- -- Representation types -------------------------------------------------------------------------------- @@ -932,16 +932,16 @@ #endif -#if __GLASGOW_HASKELL__ < 711 +#if !(MIN_VERSION_base(4,9,0)) -- | Constants of kind @#@ data family URec (a :: *) (p :: *) -# if __GLASGOW_HASKELL__ >= 707 +# if MIN_VERSION_base(4,7,0) deriving instance Typeable URec # else instance Typeable2 URec where typeOf2 _ = -# if __GLASGOW_HASKELL__ >= 701 +# if MIN_VERSION_base(4,4,0) mkTyConApp (mkTyCon3 "generic-deriving" "Generics.Deriving.Base.Internal" "URec") [] diff --git a/src/Generics/Deriving/Eq.hs b/src/Generics/Deriving/Eq.hs --- a/src/Generics/Deriving/Eq.hs +++ b/src/Generics/Deriving/Eq.hs @@ -115,7 +115,7 @@ instance GEq' UWord where geq' (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2) -#if __GLASGOW_HASKELL__ < 707 +#if !(MIN_VERSION_base(4,7,0)) isTrue# :: Bool -> Bool isTrue# = id #endif diff --git a/src/Generics/Deriving/Instances.hs b/src/Generics/Deriving/Instances.hs --- a/src/Generics/Deriving/Instances.hs +++ b/src/Generics/Deriving/Instances.hs @@ -21,7 +21,7 @@ module Generics.Deriving.Instances ( -- Only instances from Generics.Deriving.Base -- and the Generic1 instances -#if __GLASGOW_HASKELL__ < 711 +#if !(MIN_VERSION_base(4,9,0)) Rep0ExitCode , Rep0Version , Rep1ConSum @@ -46,15 +46,15 @@ , Rep1UInt , Rep0UWord , Rep1UWord -# if __GLASGOW_HASKELL__ >= 701 +# if MIN_VERSION_base(4,4,0) , Rep0Complex , Rep1Complex # endif -# if __GLASGOW_HASKELL__ >= 707 +# if MIN_VERSION_base(4,7,0) , Rep1Proxy # endif #endif -#if __GLASGOW_HASKELL__ < 708 +#if !(MIN_VERSION_base(4,7,0)) , Rep0All , Rep0Any , Rep0Arity @@ -88,7 +88,7 @@ , Rep0ConProduct , Rep0ConCompose #endif -#if __GLASGOW_HASKELL__ < 705 +#if !(MIN_VERSION_base(4,6,0)) , Rep1Either , Rep1List , Rep1Maybe @@ -99,8 +99,7 @@ , Rep1Tuple6 , Rep1Tuple7 #endif -#if __GLASGOW_HASKELL__ < 701 - -- * Representations for base types +#if !(MIN_VERSION_base(4,4,0)) , Rep0Bool , Rep0Char , Rep0Double @@ -120,26 +119,26 @@ #endif ) where -#if __GLASGOW_HASKELL__ < 708 +#if !(MIN_VERSION_base(4,7,0)) import Control.Applicative import Data.Monoid #endif -#if __GLASGOW_HASKELL__ >= 701 && __GLASGOW_HASKELL__ < 711 +#if MIN_VERSION_base(4,4,0) && !(MIN_VERSION_base(4,9,0)) import Data.Complex (Complex(..)) #endif -#if __GLASGOW_HASKELL__ >= 707 && __GLASGOW_HASKELL__ < 711 +#if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,9,0)) import Data.Proxy (Proxy(..)) #endif -#if __GLASGOW_HASKELL__ < 711 +#if !(MIN_VERSION_base(4,9,0)) import Data.Version (Version(..)) import Generics.Deriving.Base.Internal import System.Exit (ExitCode(..)) #endif -#if __GLASGOW_HASKELL__ < 711 +#if !(MIN_VERSION_base(4,9,0)) type Rep0ExitCode = D1 D1ExitCode (C1 C1_0ExitCode U1 :+: C1 C1_1ExitCode (S1 NoSelector (Rec0 Int))) @@ -215,7 +214,7 @@ instance Datatype D1ConSum where datatypeName _ = ":+:" -# if __GLASGOW_HASKELL__ < 701 +# if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" @@ -242,7 +241,7 @@ instance Datatype D1ConProduct where datatypeName _ = ":*:" -# if __GLASGOW_HASKELL__ < 701 +# if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" @@ -268,7 +267,7 @@ instance Datatype D1ConCompose where datatypeName _ = ":.:" -# if __GLASGOW_HASKELL__ < 701 +# if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" @@ -296,7 +295,7 @@ instance Datatype D1K1 where datatypeName _ = "K1" -# if __GLASGOW_HASKELL__ < 701 +# if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" @@ -324,7 +323,7 @@ instance Datatype D1M1 where datatypeName _ = "M1" -# if __GLASGOW_HASKELL__ < 701 +# if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" @@ -352,7 +351,7 @@ instance Datatype D1Par1 where datatypeName _ = "Par1" -# if __GLASGOW_HASKELL__ < 701 +# if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" @@ -380,7 +379,7 @@ instance Datatype D1Rec1 where datatypeName _ = "Rec1" -# if __GLASGOW_HASKELL__ < 701 +# if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" @@ -407,7 +406,7 @@ instance Datatype D1U1 where datatypeName _ = "U1" -# if __GLASGOW_HASKELL__ < 701 +# if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" @@ -435,7 +434,7 @@ instance Datatype D1V1 where datatypeName _ = "V1" -# if __GLASGOW_HASKELL__ < 701 +# if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" @@ -623,7 +622,7 @@ ----- -# if __GLASGOW_HASKELL__ >= 701 +# if MIN_VERSION_base(4,4,0) type Rep0Complex a = D1 D1Complex (C1 C1_0Complex (S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 a))) type Rep1Complex = D1 D1Complex (C1 C1_0Complex (S1 NoSelector Par1 @@ -653,7 +652,7 @@ ----- -# if __GLASGOW_HASKELL__ >= 707 +# if MIN_VERSION_base(4,7,0) type Rep1Proxy = D1 D1Proxy (C1 C1_0Proxy U1) instance Generic1 Proxy where @@ -675,7 +674,7 @@ ----- -#if __GLASGOW_HASKELL__ < 708 +#if !(MIN_VERSION_base(4,7,0)) -------------------------------------------------------------------------------- -- Representations for base types -------------------------------------------------------------------------------- @@ -748,7 +747,7 @@ instance Datatype D1Arity where datatypeName _ = "Arity" -# if __GLASGOW_HASKELL__ < 701 +# if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" @@ -786,7 +785,7 @@ instance Datatype D1Associativity where datatypeName _ = "Associativity" -# if __GLASGOW_HASKELL__ < 701 +# if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" @@ -938,7 +937,7 @@ instance Datatype D1Fixity where datatypeName _ = "Fixity" -# if __GLASGOW_HASKELL__ < 701 +# if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" @@ -1219,7 +1218,7 @@ ----- -#if __GLASGOW_HASKELL__ < 705 +#if !(MIN_VERSION_base(4,6,0)) type Rep1List = D1 D1List (C1 C1_0List U1 :+: C1 C1_1List (S1 NoSelector Par1 :*: S1 NoSelector (Rec1 []))) @@ -1473,7 +1472,7 @@ ----- -#if __GLASGOW_HASKELL__ < 701 +#if !(MIN_VERSION_base(4,4,0)) type Rep0Bool = D1 D1Bool (C1 C1_0Bool U1 :+: C1 C1_1Bool U1) instance Generic Bool where diff --git a/src/Generics/Deriving/TH.hs b/src/Generics/Deriving/TH.hs --- a/src/Generics/Deriving/TH.hs +++ b/src/Generics/Deriving/TH.hs @@ -90,10 +90,10 @@ import qualified Data.Map as Map (fromList) import Generics.Deriving.TH.Internal -#if __GLASGOW_HASKELL__ >= 711 -import Generics.Deriving.TH.Post711 +#if MIN_VERSION_base(4,9,0) +import Generics.Deriving.TH.Post4'9 #else -import Generics.Deriving.TH.Pre711 +import Generics.Deriving.TH.Pre4'9 #endif import Language.Haskell.TH.Lib @@ -265,7 +265,7 @@ origTy <- buildTypeInstance gClass name allTvbs dv repTySynApp <- makeRepTySynApp gClass dv name cons origTy let tyIns = TySynInstD repName -#if __GLASGOW_HASKELL__ >= 707 +#if MIN_VERSION_template_haskell(2,9,0) (TySynEqn [origTy] repTySynApp) #else [origTy] repTySynApp diff --git a/src/Generics/Deriving/TH/Internal.hs b/src/Generics/Deriving/TH/Internal.hs --- a/src/Generics/Deriving/TH/Internal.hs +++ b/src/Generics/Deriving/TH/Internal.hs @@ -696,52 +696,52 @@ gdPackageKey = "generic-deriving-" ++ showVersion version #endif -mkGD7'1_d :: String -> Name -#if __GLASGOW_HASKELL__ >= 705 -mkGD7'1_d = mkNameG_d "base" "GHC.Generics" -#elif __GLASGOW_HASKELL__ >= 701 -mkGD7'1_d = mkNameG_d "ghc-prim" "GHC.Generics" +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 -mkGD7'1_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal" +mkGD4'4_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal" #endif -mkGD7'11_d :: String -> Name -#if __GLASGOW_HASKELL__ >= 711 -mkGD7'11_d = mkNameG_d "base" "GHC.Generics" +mkGD4'9_d :: String -> Name +#if MIN_VERSION_base(4,9,0) +mkGD4'9_d = mkNameG_d "base" "GHC.Generics" #else -mkGD7'11_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal" +mkGD4'9_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal" #endif -mkGD7'1_tc :: String -> Name -#if __GLASGOW_HASKELL__ >= 705 -mkGD7'1_tc = mkNameG_tc "base" "GHC.Generics" -#elif __GLASGOW_HASKELL__ >= 701 -mkGD7'1_tc = mkNameG_tc "ghc-prim" "GHC.Generics" +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 -mkGD7'1_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal" +mkGD4'4_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal" #endif -mkGD7'11_tc :: String -> Name -#if __GLASGOW_HASKELL__ >= 711 -mkGD7'11_tc = mkNameG_tc "base" "GHC.Generics" +mkGD4'9_tc :: String -> Name +#if MIN_VERSION_base(4,9,0) +mkGD4'9_tc = mkNameG_tc "base" "GHC.Generics" #else -mkGD7'11_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal" +mkGD4'9_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal" #endif -mkGD7'1_v :: String -> Name -#if __GLASGOW_HASKELL__ >= 705 -mkGD7'1_v = mkNameG_v "base" "GHC.Generics" -#elif __GLASGOW_HASKELL__ >= 701 -mkGD7'1_v = mkNameG_v "ghc-prim" "GHC.Generics" +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 -mkGD7'1_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal" +mkGD4'4_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal" #endif -mkGD7'11_v :: String -> Name -#if __GLASGOW_HASKELL__ >= 711 -mkGD7'11_v = mkNameG_v "base" "GHC.Generics" +mkGD4'9_v :: String -> Name +#if MIN_VERSION_base(4,9,0) +mkGD4'9_v = mkNameG_v "base" "GHC.Generics" #else -mkGD7'11_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal" +mkGD4'9_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal" #endif mkBaseName_d :: String -> String -> Name @@ -754,207 +754,205 @@ mkGHCPrimName_tc = mkNameG_tc "ghc-prim" comp1DataName :: Name -comp1DataName = mkGD7'1_d "Comp1" +comp1DataName = mkGD4'4_d "Comp1" infixDataName :: Name -infixDataName = mkGD7'1_d "Infix" +infixDataName = mkGD4'4_d "Infix" k1DataName :: Name -k1DataName = mkGD7'1_d "K1" +k1DataName = mkGD4'4_d "K1" l1DataName :: Name -l1DataName = mkGD7'1_d "L1" +l1DataName = mkGD4'4_d "L1" leftAssociativeDataName :: Name -leftAssociativeDataName = mkGD7'1_d "LeftAssociative" +leftAssociativeDataName = mkGD4'4_d "LeftAssociative" m1DataName :: Name -m1DataName = mkGD7'1_d "M1" +m1DataName = mkGD4'4_d "M1" notAssociativeDataName :: Name -notAssociativeDataName = mkGD7'1_d "NotAssociative" +notAssociativeDataName = mkGD4'4_d "NotAssociative" par1DataName :: Name -par1DataName = mkGD7'1_d "Par1" +par1DataName = mkGD4'4_d "Par1" prefixDataName :: Name -prefixDataName = mkGD7'1_d "Prefix" +prefixDataName = mkGD4'4_d "Prefix" productDataName :: Name -productDataName = mkGD7'1_d ":*:" +productDataName = mkGD4'4_d ":*:" r1DataName :: Name -r1DataName = mkGD7'1_d "R1" +r1DataName = mkGD4'4_d "R1" rec1DataName :: Name -rec1DataName = mkGD7'1_d "Rec1" +rec1DataName = mkGD4'4_d "Rec1" rightAssociativeDataName :: Name -rightAssociativeDataName = mkGD7'1_d "RightAssociative" +rightAssociativeDataName = mkGD4'4_d "RightAssociative" u1DataName :: Name -u1DataName = mkGD7'1_d "U1" +u1DataName = mkGD4'4_d "U1" uAddrDataName :: Name -uAddrDataName = mkGD7'11_d "UAddr" +uAddrDataName = mkGD4'9_d "UAddr" uCharDataName :: Name -uCharDataName = mkGD7'11_d "UChar" +uCharDataName = mkGD4'9_d "UChar" uDoubleDataName :: Name -uDoubleDataName = mkGD7'11_d "UDouble" +uDoubleDataName = mkGD4'9_d "UDouble" uFloatDataName :: Name -uFloatDataName = mkGD7'11_d "UFloat" +uFloatDataName = mkGD4'9_d "UFloat" uIntDataName :: Name -uIntDataName = mkGD7'11_d "UInt" +uIntDataName = mkGD4'9_d "UInt" uWordDataName :: Name -uWordDataName = mkGD7'11_d "UWord" +uWordDataName = mkGD4'9_d "UWord" c1TypeName :: Name -c1TypeName = mkGD7'1_tc "C1" +c1TypeName = mkGD4'4_tc "C1" composeTypeName :: Name -composeTypeName = mkGD7'1_tc ":.:" +composeTypeName = mkGD4'4_tc ":.:" constructorTypeName :: Name -constructorTypeName = mkGD7'1_tc "Constructor" +constructorTypeName = mkGD4'4_tc "Constructor" d1TypeName :: Name -d1TypeName = mkGD7'1_tc "D1" +d1TypeName = mkGD4'4_tc "D1" genericTypeName :: Name -genericTypeName = mkGD7'1_tc "Generic" +genericTypeName = mkGD4'4_tc "Generic" generic1TypeName :: Name -generic1TypeName = mkGD7'1_tc "Generic1" +generic1TypeName = mkGD4'4_tc "Generic1" datatypeTypeName :: Name -datatypeTypeName = mkGD7'1_tc "Datatype" +datatypeTypeName = mkGD4'4_tc "Datatype" noSelectorTypeName :: Name -noSelectorTypeName = mkGD7'1_tc "NoSelector" +noSelectorTypeName = mkGD4'4_tc "NoSelector" par1TypeName :: Name -par1TypeName = mkGD7'1_tc "Par1" +par1TypeName = mkGD4'4_tc "Par1" productTypeName :: Name -productTypeName = mkGD7'1_tc ":*:" +productTypeName = mkGD4'4_tc ":*:" rec0TypeName :: Name -rec0TypeName = mkGD7'1_tc "Rec0" +rec0TypeName = mkGD4'4_tc "Rec0" rec1TypeName :: Name -rec1TypeName = mkGD7'1_tc "Rec1" +rec1TypeName = mkGD4'4_tc "Rec1" repTypeName :: Name -repTypeName = mkGD7'1_tc "Rep" +repTypeName = mkGD4'4_tc "Rep" rep1TypeName :: Name -rep1TypeName = mkGD7'1_tc "Rep1" +rep1TypeName = mkGD4'4_tc "Rep1" s1TypeName :: Name -s1TypeName = mkGD7'1_tc "S1" +s1TypeName = mkGD4'4_tc "S1" selectorTypeName :: Name -selectorTypeName = mkGD7'1_tc "Selector" +selectorTypeName = mkGD4'4_tc "Selector" sumTypeName :: Name -sumTypeName = mkGD7'1_tc ":+:" +sumTypeName = mkGD4'4_tc ":+:" u1TypeName :: Name -u1TypeName = mkGD7'1_tc "U1" +u1TypeName = mkGD4'4_tc "U1" uAddrTypeName :: Name -uAddrTypeName = mkGD7'11_tc "UAddr" +uAddrTypeName = mkGD4'9_tc "UAddr" uCharTypeName :: Name -uCharTypeName = mkGD7'11_tc "UChar" +uCharTypeName = mkGD4'9_tc "UChar" uDoubleTypeName :: Name -uDoubleTypeName = mkGD7'11_tc "UDouble" +uDoubleTypeName = mkGD4'9_tc "UDouble" uFloatTypeName :: Name -uFloatTypeName = mkGD7'11_tc "UFloat" +uFloatTypeName = mkGD4'9_tc "UFloat" uIntTypeName :: Name -uIntTypeName = mkGD7'11_tc "UInt" +uIntTypeName = mkGD4'9_tc "UInt" uWordTypeName :: Name -uWordTypeName = mkGD7'11_tc "UWord" +uWordTypeName = mkGD4'9_tc "UWord" v1TypeName :: Name -v1TypeName = mkGD7'1_tc "V1" +v1TypeName = mkGD4'4_tc "V1" conFixityValName :: Name -conFixityValName = mkGD7'1_v "conFixity" +conFixityValName = mkGD4'4_v "conFixity" conIsRecordValName :: Name -conIsRecordValName = mkGD7'1_v "conIsRecord" +conIsRecordValName = mkGD4'4_v "conIsRecord" conNameValName :: Name -conNameValName = mkGD7'1_v "conName" +conNameValName = mkGD4'4_v "conName" datatypeNameValName :: Name -datatypeNameValName = mkGD7'1_v "datatypeName" +datatypeNameValName = mkGD4'4_v "datatypeName" -#if __GLASGOW_HASKELL__ >= 708 isNewtypeValName :: Name -isNewtypeValName = mkGD7'1_v "isNewtype" -#endif +isNewtypeValName = mkGD4'4_v "isNewtype" fromValName :: Name -fromValName = mkGD7'1_v "from" +fromValName = mkGD4'4_v "from" from1ValName :: Name -from1ValName = mkGD7'1_v "from1" +from1ValName = mkGD4'4_v "from1" moduleNameValName :: Name -moduleNameValName = mkGD7'1_v "moduleName" +moduleNameValName = mkGD4'4_v "moduleName" selNameValName :: Name -selNameValName = mkGD7'1_v "selName" +selNameValName = mkGD4'4_v "selName" toValName :: Name -toValName = mkGD7'1_v "to" +toValName = mkGD4'4_v "to" to1ValName :: Name -to1ValName = mkGD7'1_v "to1" +to1ValName = mkGD4'4_v "to1" uAddrHashValName :: Name -uAddrHashValName = mkGD7'11_v "uAddr#" +uAddrHashValName = mkGD4'9_v "uAddr#" uCharHashValName :: Name -uCharHashValName = mkGD7'11_v "uChar#" +uCharHashValName = mkGD4'9_v "uChar#" uDoubleHashValName :: Name -uDoubleHashValName = mkGD7'11_v "uDouble#" +uDoubleHashValName = mkGD4'9_v "uDouble#" uFloatHashValName :: Name -uFloatHashValName = mkGD7'11_v "uFloat#" +uFloatHashValName = mkGD4'9_v "uFloat#" uIntHashValName :: Name -uIntHashValName = mkGD7'11_v "uInt#" +uIntHashValName = mkGD4'9_v "uInt#" uWordHashValName :: Name -uWordHashValName = mkGD7'11_v "uWord#" +uWordHashValName = mkGD4'9_v "uWord#" unComp1ValName :: Name -unComp1ValName = mkGD7'1_v "unComp1" +unComp1ValName = mkGD4'4_v "unComp1" unK1ValName :: Name -unK1ValName = mkGD7'1_v "unK1" +unK1ValName = mkGD4'4_v "unK1" unPar1ValName :: Name -unPar1ValName = mkGD7'1_v "unPar1" +unPar1ValName = mkGD4'4_v "unPar1" unRec1ValName :: Name -unRec1ValName = mkGD7'1_v "unRec1" +unRec1ValName = mkGD4'4_v "unRec1" trueDataName, falseDataName :: Name -#if __GLASGOW_HASKELL__ >= 701 +#if MIN_VERSION_base(4,4,0) trueDataName = mkGHCPrimName_d "GHC.Types" "True" falseDataName = mkGHCPrimName_d "GHC.Types" "False" #else @@ -963,7 +961,7 @@ #endif nothingDataName, justDataName :: Name -#if __GLASGOW_HASKELL__ >= 709 +#if MIN_VERSION_base(4,8,0) nothingDataName = mkBaseName_d "GHC.Base" "Nothing" justDataName = mkBaseName_d "GHC.Base" "Just" #else @@ -1004,57 +1002,53 @@ undefinedValName :: Name undefinedValName = mkNameG_v "base" "GHC.Err" "undefined" -#if __GLASGOW_HASKELL__ >= 705 && __GLASGOW_HASKELL__ < 711 starKindName :: Name starKindName = mkGHCPrimName_tc "GHC.Prim" "*" -#endif -#if __GLASGOW_HASKELL__ >= 711 decidedLazyDataName :: Name -decidedLazyDataName = mkGD7'11_d "DecidedLazy" +decidedLazyDataName = mkGD4'9_d "DecidedLazy" decidedStrictDataName :: Name -decidedStrictDataName = mkGD7'11_d "DecidedStrict" +decidedStrictDataName = mkGD4'9_d "DecidedStrict" decidedUnpackDataName :: Name -decidedUnpackDataName = mkGD7'11_d "DecidedUnpack" +decidedUnpackDataName = mkGD4'9_d "DecidedUnpack" infixIDataName :: Name -infixIDataName = mkGD7'11_d "InfixI" +infixIDataName = mkGD4'9_d "InfixI" metaConsDataName :: Name -metaConsDataName = mkGD7'11_d "MetaCons" +metaConsDataName = mkGD4'9_d "MetaCons" metaDataDataName :: Name -metaDataDataName = mkGD7'11_d "MetaData" +metaDataDataName = mkGD4'9_d "MetaData" metaNoSelDataName :: Name -metaNoSelDataName = mkGD7'11_d "MetaNoSel" +metaNoSelDataName = mkGD4'9_d "MetaNoSel" metaSelDataName :: Name -metaSelDataName = mkGD7'11_d "MetaSel" +metaSelDataName = mkGD4'9_d "MetaSel" noSourceStrictnessDataName :: Name -noSourceStrictnessDataName = mkGD7'11_d "NoSourceStrictness" +noSourceStrictnessDataName = mkGD4'9_d "NoSourceStrictness" noSourceUnpackednessDataName :: Name -noSourceUnpackednessDataName = mkGD7'11_d "NoSourceUnpackedness" +noSourceUnpackednessDataName = mkGD4'9_d "NoSourceUnpackedness" prefixIDataName :: Name -prefixIDataName = mkGD7'11_d "PrefixI" +prefixIDataName = mkGD4'9_d "PrefixI" sourceLazyDataName :: Name -sourceLazyDataName = mkGD7'11_d "SourceLazy" +sourceLazyDataName = mkGD4'9_d "SourceLazy" sourceNoUnpackDataName :: Name -sourceNoUnpackDataName = mkGD7'11_d "SourceNoUnpack" +sourceNoUnpackDataName = mkGD4'9_d "SourceNoUnpack" sourceStrictDataName :: Name -sourceStrictDataName = mkGD7'11_d "SourceStrict" +sourceStrictDataName = mkGD4'9_d "SourceStrict" sourceUnpackDataName :: Name -sourceUnpackDataName = mkGD7'11_d "SourceUnpack" +sourceUnpackDataName = mkGD4'9_d "SourceUnpack" packageNameValName :: Name -packageNameValName = mkGD7'1_v "packageName" -#endif +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.Lib +import Language.Haskell.TH.Syntax + +mkMetaDataType :: DataVariety -> Name -> Bool -> Q Type +mkMetaDataType _ n isNewtype = + promotedT metaDataDataName + `appT` litT (strTyLit (nameBase n)) + `appT` litT (strTyLit m) + `appT` litT (strTyLit pkg) + `appT` promoteBool isNewtype + where + m, pkg :: String + m = fromMaybe (error "Cannot fetch module name!") (nameModule n) + pkg = fromMaybe (error "Cannot fetch package name!") (namePackage n) + +mkMetaConsType :: DataVariety -> 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 :: DataVariety -> 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` promoteSourceUnpackedness su + `appT` promoteSourceStrictness ss + `appT` promoteDecidedStrictness ds + +data SelStrictInfo = SelStrictInfo SourceUnpackedness SourceStrictness DecidedStrictness + +promoteSourceUnpackedness :: SourceUnpackedness -> Q Type +promoteSourceUnpackedness NoSourceUnpackedness = promotedT noSourceUnpackednessDataName +promoteSourceUnpackedness SourceNoUnpack = promotedT sourceNoUnpackDataName +promoteSourceUnpackedness SourceUnpack = promotedT sourceUnpackDataName + +promoteSourceStrictness :: SourceStrictness -> Q Type +promoteSourceStrictness NoSourceStrictness = promotedT noSourceStrictnessDataName +promoteSourceStrictness SourceLazy = promotedT sourceLazyDataName +promoteSourceStrictness SourceStrict = promotedT sourceStrictDataName + +promoteDecidedStrictness :: DecidedStrictness -> Q Type +promoteDecidedStrictness DecidedLazy = promotedT decidedLazyDataName +promoteDecidedStrictness DecidedStrict = promotedT decidedStrictDataName +promoteDecidedStrictness DecidedUnpack = promotedT decidedUnpackDataName + +reifySelStrictInfo :: Name -> [Bang] -> Q [SelStrictInfo] +reifySelStrictInfo conName bangs = do + dcdStrs <- reifyConStrictness conName + let (srcUnpks, srcStrs) = unzip $ map splitBang bangs + return $ zipWith3 SelStrictInfo srcUnpks srcStrs dcdStrs + +splitBang :: Bang -> (SourceUnpackedness, SourceStrictness) +splitBang (Bang su ss) = (su, ss) + +-- | 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/Generics/Deriving/TH/Post711.hs b/src/Generics/Deriving/TH/Post711.hs deleted file mode 100644 --- a/src/Generics/Deriving/TH/Post711.hs +++ /dev/null @@ -1,137 +0,0 @@ -{- | -Module : Generics.Deriving.TH.Post711 -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 GHC 7.11. --} - -module Generics.Deriving.TH.Post711 ( - deriveMeta - , deriveData - , deriveConstructors - , deriveSelectors - , mkMetaDataType - , mkMetaConsType - , mkMetaSelType - , SelStrictInfo(..) - , reifySelStrictInfo - ) where - -import Data.Maybe (fromMaybe) - -import Generics.Deriving.TH.Internal - -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax - -mkMetaDataType :: DataVariety -> Name -> Bool -> Q Type -mkMetaDataType _ n isNewtype = - promotedT metaDataDataName - `appT` litT (strTyLit (nameBase n)) - `appT` litT (strTyLit m) - `appT` litT (strTyLit pkg) - `appT` promoteBool isNewtype - where - m, pkg :: String - m = fromMaybe (error "Cannot fetch module name!") (nameModule n) - pkg = fromMaybe (error "Cannot fetch package name!") (namePackage n) - -mkMetaConsType :: DataVariety -> 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 :: DataVariety -> 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` promoteSourceUnpackedness su - `appT` promoteSourceStrictness ss - `appT` promoteDecidedStrictness ds - -data SelStrictInfo = SelStrictInfo SourceUnpackedness SourceStrictness DecidedStrictness - -promoteSourceUnpackedness :: SourceUnpackedness -> Q Type -promoteSourceUnpackedness NoSourceUnpackedness = promotedT noSourceUnpackednessDataName -promoteSourceUnpackedness SourceNoUnpack = promotedT sourceNoUnpackDataName -promoteSourceUnpackedness SourceUnpack = promotedT sourceUnpackDataName - -promoteSourceStrictness :: SourceStrictness -> Q Type -promoteSourceStrictness NoSourceStrictness = promotedT noSourceStrictnessDataName -promoteSourceStrictness SourceLazy = promotedT sourceLazyDataName -promoteSourceStrictness SourceStrict = promotedT sourceStrictDataName - -promoteDecidedStrictness :: DecidedStrictness -> Q Type -promoteDecidedStrictness DecidedLazy = promotedT decidedLazyDataName -promoteDecidedStrictness DecidedStrict = promotedT decidedStrictDataName -promoteDecidedStrictness DecidedUnpack = promotedT decidedUnpackDataName - -reifySelStrictInfo :: Name -> [Bang] -> Q [SelStrictInfo] -reifySelStrictInfo conName bangs = do - dcdStrs <- reifyConStrictness conName - let (srcUnpks, srcStrs) = unzip $ map splitBang bangs - return $ zipWith3 SelStrictInfo srcUnpks srcStrs dcdStrs - -splitBang :: Bang -> (SourceUnpackedness, SourceStrictness) -splitBang (Bang su ss) = (su, ss) - --- | 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/Generics/Deriving/TH/Pre4'9.hs b/src/Generics/Deriving/TH/Pre4'9.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/TH/Pre4'9.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE CPP #-} + +{- | +Module : Generics.Deriving.TH.Pre4'9 +Copyright : (c) 2008--2009 Universiteit Utrecht +License : BSD3 + +Maintainer : generics@haskell.org +Stability : experimental +Portability : non-portable + +Template Haskell machinery for the proxy datatype variant of GHC generics +used up until @base-4.9@. +-} + +module Generics.Deriving.TH.Pre4'9 ( + deriveMeta + , deriveData + , deriveConstructors + , deriveSelectors + , mkMetaDataType + , mkMetaConsType + , mkMetaSelType + , SelStrictInfo + , reifySelStrictInfo + ) where + +import Data.List (intercalate) +import Data.Maybe (fromMaybe) + +import Generics.Deriving.TH.Internal + +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +-- | Given the type and the name (as string) for the type to derive, +-- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector' +-- instances. +deriveMeta :: Name -> Q [Dec] +deriveMeta n = + do a <- deriveData n + b <- deriveConstructors n + c <- deriveSelectors n + return (a ++ b ++ c) + +-- | Given a datatype name, derive a datatype and instance of class 'Datatype'. +deriveData :: Name -> Q [Dec] +deriveData = dataInstance + +-- | Given a datatype name, derive datatypes and +-- instances of class 'Constructor'. +deriveConstructors :: Name -> Q [Dec] +deriveConstructors = constrInstance + +-- | Given a datatype name, derive datatypes and instances of class 'Selector'. +deriveSelectors :: Name -> Q [Dec] +deriveSelectors = selectInstance + +dataInstance :: Name -> Q [Dec] +dataInstance n = do + i <- reifyDataInfo n + case i of + Left _ -> return [] + Right (n', isNT, _, _, dv) -> mkInstance n' dv isNT + where + mkInstance n' dv isNT = do + ds <- mkDataData dv n' + is <- mkDataInstance dv n' isNT + return $ [ds,is] + +constrInstance :: Name -> Q [Dec] +constrInstance n = do + i <- reifyDataInfo n + case i of + Left _ -> return [] + Right (n', _, _, cs, dv) -> mkInstance n' cs dv + where + mkInstance n' cs dv = do + ds <- mapM (mkConstrData dv n') cs + is <- mapM (mkConstrInstance dv n') cs + return $ ds ++ is + +selectInstance :: Name -> Q [Dec] +selectInstance n = do + i <- reifyDataInfo n + case i of + Left _ -> return [] + Right (n', _, _, cs, dv) -> mkInstance n' cs dv + where + mkInstance n' cs dv = do + ds <- mapM (mkSelectData dv n') cs + is <- mapM (mkSelectInstance dv n') cs + return $ concat (ds ++ is) + +mkDataData :: DataVariety -> Name -> Q Dec +mkDataData dv n = dataD (cxt []) (genName dv [n]) [] +#if MIN_VERSION_template_haskell(2,11,0) + Nothing [] (cxt []) +#else + [] [] +#endif + +mkConstrData :: DataVariety -> Name -> Con -> Q Dec +mkConstrData dv dt (NormalC n _) = + dataD (cxt []) (genName dv [dt, n]) [] +#if MIN_VERSION_template_haskell(2,11,0) + Nothing [] (cxt []) +#else + [] [] +#endif +mkConstrData dv dt (RecC n f) = + mkConstrData dv dt (NormalC n (map shrink f)) +mkConstrData dv dt (InfixC t1 n t2) = + mkConstrData dv dt (NormalC n [t1,t2]) +mkConstrData _ _ con = gadtError con + +mkSelectData :: DataVariety -> Name -> Con -> Q [Dec] +mkSelectData dv dt (RecC n fs) = return (map one fs) + where one (f, _, _) = DataD [] (genName dv [dt, n, f]) [] +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif + [] [] +mkSelectData _ _ _ = return [] + +mkDataInstance :: DataVariety -> Name -> Bool -> Q Dec +mkDataInstance dv n isNewtype = + instanceD (cxt []) (appT (conT datatypeTypeName) (mkMetaDataType dv n isNewtype)) $ + [ funD datatypeNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] + , funD moduleNameValName [clause [wildP] (normalB (stringE name)) []] + ] +#if MIN_VERSION_base(4,7,0) + ++ if isNewtype + then [funD isNewtypeValName [clause [wildP] (normalB (conE trueDataName)) []]] + else [] +#endif + where + name = fromMaybe (error "Cannot fetch module name!") (nameModule n) + +liftFixity :: Fixity -> Q Exp +liftFixity (Fixity n a) = conE infixDataName + `appE` liftAssociativity a + `appE` lift n + +liftAssociativity :: FixityDirection -> Q Exp +liftAssociativity InfixL = conE leftAssociativeDataName +liftAssociativity InfixR = conE rightAssociativeDataName +liftAssociativity InfixN = conE notAssociativeDataName + +mkConstrInstance :: DataVariety -> Name -> Con -> Q Dec +mkConstrInstance dv dt (NormalC n _) = mkConstrInstanceWith dv dt n False False [] +mkConstrInstance dv dt (RecC n _) = + mkConstrInstanceWith dv dt n True False + [funD conIsRecordValName [clause [wildP] (normalB (conE trueDataName)) []]] +mkConstrInstance dv dt (InfixC _ n _) = do + i <- reify n +#if MIN_VERSION_template_haskell(2,11,0) + fi <- case i of + DataConI{} -> fromMaybe defaultFixity `fmap` reifyFixity n +#else + let fi = case i of + DataConI _ _ _ f -> f +#endif + _ -> error $ "Not a data constructor name: " ++ show n + mkConstrInstanceWith dv dt n False True + [funD conFixityValName [clause [wildP] (normalB (liftFixity fi)) []]] +mkConstrInstance _ _ con = gadtError con + +mkConstrInstanceWith :: DataVariety + -> Name + -> Name + -> Bool + -> Bool + -> [Q Dec] + -> Q Dec +mkConstrInstanceWith dv dt n isRecord isInfix extra = + instanceD + (cxt []) + (appT (conT constructorTypeName) (mkMetaConsType dv dt n isRecord isInfix)) + (funD conNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra) + +mkSelectInstance :: DataVariety -> Name -> Con -> Q [Dec] +mkSelectInstance dv dt (RecC n fs) = mapM (one . fst3) fs where + one :: Name -> Q Dec + one f = + instanceD (cxt []) (appT (conT selectorTypeName) (mkMetaSelType dv dt n (Just f) ())) + [funD selNameValName [clause [wildP] + (normalB (litE (stringL (nameBase f)))) []]] +mkSelectInstance _ _ _ = return [] + +genName :: DataVariety -> [Name] -> Name +genName dv ns = mkName + . showsDataVariety dv + . intercalate "_" + . consQualName + $ map (sanitizeName . nameBase) ns + where + consQualName :: [String] -> [String] + consQualName = case ns of + [] -> id + n:_ -> (showNameQual n :) + +mkMetaDataType :: DataVariety -> Name -> Bool -> Q Type +mkMetaDataType dv n _ = conT $ genName dv [n] + +mkMetaConsType :: DataVariety -> Name -> Name -> Bool -> Bool -> Q Type +mkMetaConsType dv dt n _ _ = conT $ genName dv [dt, n] + +mkMetaSelType :: DataVariety -> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type +mkMetaSelType dv dt n (Just f) () = conT $ genName dv [dt, n, f] +mkMetaSelType _ _ _ Nothing () = conT noSelectorTypeName + +type SelStrictInfo = () + +reifySelStrictInfo :: Name -> [Strict] -> Q [SelStrictInfo] +reifySelStrictInfo _ bangs = return (map (const ()) bangs) diff --git a/src/Generics/Deriving/TH/Pre711.hs b/src/Generics/Deriving/TH/Pre711.hs deleted file mode 100644 --- a/src/Generics/Deriving/TH/Pre711.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE CPP #-} - -{- | -Module : Generics.Deriving.TH.Pre711 -Copyright : (c) 2008--2009 Universiteit Utrecht -License : BSD3 - -Maintainer : generics@haskell.org -Stability : experimental -Portability : non-portable - -Template Haskell machinery for the proxy datatype variant of GHC generics -used up until GHC 7.11. --} - -module Generics.Deriving.TH.Pre711 ( - deriveMeta - , deriveData - , deriveConstructors - , deriveSelectors - , mkMetaDataType - , mkMetaConsType - , mkMetaSelType - , SelStrictInfo - , reifySelStrictInfo - ) where - -import Data.List (intercalate) -import Data.Maybe (fromMaybe) - -import Generics.Deriving.TH.Internal - -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax - --- | Given the type and the name (as string) for the type to derive, --- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector' --- instances. -deriveMeta :: Name -> Q [Dec] -deriveMeta n = - do a <- deriveData n - b <- deriveConstructors n - c <- deriveSelectors n - return (a ++ b ++ c) - --- | Given a datatype name, derive a datatype and instance of class 'Datatype'. -deriveData :: Name -> Q [Dec] -deriveData = dataInstance - --- | Given a datatype name, derive datatypes and --- instances of class 'Constructor'. -deriveConstructors :: Name -> Q [Dec] -deriveConstructors = constrInstance - --- | Given a datatype name, derive datatypes and instances of class 'Selector'. -deriveSelectors :: Name -> Q [Dec] -deriveSelectors = selectInstance - -dataInstance :: Name -> Q [Dec] -dataInstance n = do - i <- reifyDataInfo n - case i of - Left _ -> return [] - Right (n', isNT, _, _, dv) -> mkInstance n' dv isNT - where - mkInstance n' dv isNT = do - ds <- mkDataData dv n' - is <- mkDataInstance dv n' isNT - return $ [ds,is] - -constrInstance :: Name -> Q [Dec] -constrInstance n = do - i <- reifyDataInfo n - case i of - Left _ -> return [] - Right (n', _, _, cs, dv) -> mkInstance n' cs dv - where - mkInstance n' cs dv = do - ds <- mapM (mkConstrData dv n') cs - is <- mapM (mkConstrInstance dv n') cs - return $ ds ++ is - -selectInstance :: Name -> Q [Dec] -selectInstance n = do - i <- reifyDataInfo n - case i of - Left _ -> return [] - Right (n', _, _, cs, dv) -> mkInstance n' cs dv - where - mkInstance n' cs dv = do - ds <- mapM (mkSelectData dv n') cs - is <- mapM (mkSelectInstance dv n') cs - return $ concat (ds ++ is) - -mkDataData :: DataVariety -> Name -> Q Dec -mkDataData dv n = dataD (cxt []) (genName dv [n]) [] [] [] - -mkConstrData :: DataVariety -> Name -> Con -> Q Dec -mkConstrData dv dt (NormalC n _) = - dataD (cxt []) (genName dv [dt, n]) [] [] [] -mkConstrData dv dt (RecC n f) = - mkConstrData dv dt (NormalC n (map shrink f)) -mkConstrData dv dt (InfixC t1 n t2) = - mkConstrData dv dt (NormalC n [t1,t2]) -mkConstrData _ _ con = gadtError con - -mkSelectData :: DataVariety -> Name -> Con -> Q [Dec] -mkSelectData dv dt (RecC n fs) = return (map one fs) - where one (f, _, _) = DataD [] (genName dv [dt, n, f]) [] [] [] -mkSelectData _ _ _ = return [] - -mkDataInstance :: DataVariety -> Name -> Bool -> Q Dec -mkDataInstance dv n isNewtype = - instanceD (cxt []) (appT (conT datatypeTypeName) (mkMetaDataType dv n isNewtype)) $ - [ funD datatypeNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] - , funD moduleNameValName [clause [wildP] (normalB (stringE name)) []] - ] -#if __GLASGOW_HASKELL__ >= 708 - ++ if isNewtype - then [funD isNewtypeValName [clause [wildP] (normalB (conE trueDataName)) []]] - else [] -#endif - where - name = fromMaybe (error "Cannot fetch module name!") (nameModule n) - -liftFixity :: Fixity -> Q Exp -liftFixity (Fixity n a) = conE infixDataName - `appE` liftAssociativity a - `appE` lift n - -liftAssociativity :: FixityDirection -> Q Exp -liftAssociativity InfixL = conE leftAssociativeDataName -liftAssociativity InfixR = conE rightAssociativeDataName -liftAssociativity InfixN = conE notAssociativeDataName - -mkConstrInstance :: DataVariety -> Name -> Con -> Q Dec -mkConstrInstance dv dt (NormalC n _) = mkConstrInstanceWith dv dt n False False [] -mkConstrInstance dv dt (RecC n _) = - mkConstrInstanceWith dv dt n True False - [funD conIsRecordValName [clause [wildP] (normalB (conE trueDataName)) []]] -mkConstrInstance dv dt (InfixC _ n _) = do - i <- reify n - let fi = case i of - DataConI _ _ _ f -> f - _ -> error $ "Not a data constructor name: " ++ show n - mkConstrInstanceWith dv dt n False True - [funD conFixityValName [clause [wildP] (normalB (liftFixity fi)) []]] -mkConstrInstance _ _ con = gadtError con - -mkConstrInstanceWith :: DataVariety - -> Name - -> Name - -> Bool - -> Bool - -> [Q Dec] - -> Q Dec -mkConstrInstanceWith dv dt n isRecord isInfix extra = - instanceD - (cxt []) - (appT (conT constructorTypeName) (mkMetaConsType dv dt n isRecord isInfix)) - (funD conNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra) - -mkSelectInstance :: DataVariety -> Name -> Con -> Q [Dec] -mkSelectInstance dv dt (RecC n fs) = mapM (one . fst3) fs where - one :: Name -> Q Dec - one f = - instanceD (cxt []) (appT (conT selectorTypeName) (mkMetaSelType dv dt n (Just f) ())) - [funD selNameValName [clause [wildP] - (normalB (litE (stringL (nameBase f)))) []]] -mkSelectInstance _ _ _ = return [] - -genName :: DataVariety -> [Name] -> Name -genName dv ns = mkName - . showsDataVariety dv - . intercalate "_" - . consQualName - $ map (sanitizeName . nameBase) ns - where - consQualName :: [String] -> [String] - consQualName = case ns of - [] -> id - n:_ -> (showNameQual n :) - -mkMetaDataType :: DataVariety -> Name -> Bool -> Q Type -mkMetaDataType dv n _ = conT $ genName dv [n] - -mkMetaConsType :: DataVariety -> Name -> Name -> Bool -> Bool -> Q Type -mkMetaConsType dv dt n _ _ = conT $ genName dv [dt, n] - -mkMetaSelType :: DataVariety -> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type -mkMetaSelType dv dt n (Just f) () = conT $ genName dv [dt, n, f] -mkMetaSelType _ _ _ Nothing () = conT noSelectorTypeName - -type SelStrictInfo = () - -reifySelStrictInfo :: Name -> [Strict] -> Q [SelStrictInfo] -reifySelStrictInfo _ bangs = return (map (const ()) bangs)