diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 1.10.7 +* Renamed internal modules to avoid using apostrophes (averting this bug: + https://github.com/haskell/cabal/issues/3631) + # 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`. 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.6 +version: 1.10.7 synopsis: Generic programming library for generalised deriving. description: @@ -69,10 +69,10 @@ Paths_generic_deriving if flag(base-4-9) build-depends: base >= 4.9 && < 5 - other-modules: Generics.Deriving.TH.Post4'9 + other-modules: Generics.Deriving.TH.Post4_9 else build-depends: base >= 4.3 && < 4.9 - other-modules: Generics.Deriving.TH.Pre4'9 + other-modules: Generics.Deriving.TH.Pre4_9 build-depends: containers >= 0.1 && < 0.6 , ghc-prim < 1 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 @@ -91,9 +91,9 @@ import Generics.Deriving.TH.Internal #if MIN_VERSION_base(4,9,0) -import Generics.Deriving.TH.Post4'9 +import Generics.Deriving.TH.Post4_9 #else -import Generics.Deriving.TH.Pre4'9 +import Generics.Deriving.TH.Pre4_9 #endif import Language.Haskell.TH.Lib diff --git a/src/Generics/Deriving/TH/Post4'9.hs b/src/Generics/Deriving/TH/Post4'9.hs deleted file mode 100644 --- a/src/Generics/Deriving/TH/Post4'9.hs +++ /dev/null @@ -1,137 +0,0 @@ -{- | -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/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/Pre4'9.hs b/src/Generics/Deriving/TH/Pre4'9.hs deleted file mode 100644 --- a/src/Generics/Deriving/TH/Pre4'9.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# 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/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)