generic-deriving 1.10.5 → 1.10.6
raw patch · 13 files changed
+529/−508 lines, 13 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- examples/Examples.hs +1/−1
- generic-deriving.cabal +14/−9
- src/Generics/Deriving/Base.hs +1/−1
- src/Generics/Deriving/Base/Internal.hs +9/−9
- src/Generics/Deriving/Eq.hs +1/−1
- src/Generics/Deriving/Instances.hs +28/−29
- src/Generics/Deriving/TH.hs +4/−4
- src/Generics/Deriving/TH/Internal.hs +114/−120
- src/Generics/Deriving/TH/Post4'9.hs +137/−0
- src/Generics/Deriving/TH/Post711.hs +0/−137
- src/Generics/Deriving/TH/Pre4'9.hs +216/−0
- src/Generics/Deriving/TH/Pre711.hs +0/−197
CHANGELOG.md view
@@ -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
examples/Examples.hs view
@@ -18,7 +18,7 @@ {-# LANGUAGE DeriveGeneric #-} #endif -#if __GLASGOW_HASKELL__ >= 711+#if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE DataKinds #-} #endif
generic-deriving.cabal view
@@ -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
src/Generics/Deriving/Base.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702+#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif
src/Generics/Deriving/Base/Internal.hs view
@@ -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") []
src/Generics/Deriving/Eq.hs view
@@ -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
src/Generics/Deriving/Instances.hs view
@@ -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
src/Generics/Deriving/TH.hs view
@@ -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
src/Generics/Deriving/TH/Internal.hs view
@@ -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"
+ src/Generics/Deriving/TH/Post4'9.hs view
@@ -0,0 +1,137 @@+{- |+Module : Generics.Deriving.TH.Post4'9+Copyright : (c) 2008--2009 Universiteit Utrecht+License : BSD3++Maintainer : generics@haskell.org+Stability : experimental+Portability : non-portable++Template Haskell machinery for the type-literal-based variant of GHC+generics introduced in @base-4.9@.+-}++module Generics.Deriving.TH.Post4'9 (+ deriveMeta+ , deriveData+ , deriveConstructors+ , deriveSelectors+ , mkMetaDataType+ , mkMetaConsType+ , mkMetaSelType+ , SelStrictInfo(..)+ , reifySelStrictInfo+ ) where++import Data.Maybe (fromMaybe)++import Generics.Deriving.TH.Internal++import Language.Haskell.TH.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 []
− src/Generics/Deriving/TH/Post711.hs
@@ -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 []
+ src/Generics/Deriving/TH/Pre4'9.hs view
@@ -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)
− src/Generics/Deriving/TH/Pre711.hs
@@ -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)