diff options
Diffstat (limited to 'libraries/template-haskell')
4 files changed, 64 insertions, 34 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index 35bca47d25..542f1e16b6 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -23,7 +23,7 @@ import qualified Language.Haskell.TH.Syntax as TH import Control.Applicative(liftA, Applicative(..)) import qualified Data.Kind as Kind (Type) import Data.Word( Word8 ) -import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.List.NonEmpty ( NonEmpty(..), toList ) import GHC.Exts (TYPE) import Prelude hiding (Applicative(..)) @@ -680,10 +680,10 @@ forallC ns ctxt con = do con' <- con pure $ ForallC ns' ctxt' con' -gadtC :: Quote m => [Name] -> [m StrictType] -> m Type -> m Con +gadtC :: Quote m => NonEmpty Name -> [m StrictType] -> m Type -> m Con gadtC cons strtys ty = liftA2 (GadtC cons) (sequenceA strtys) ty -recGadtC :: Quote m => [Name] -> [m VarStrictType] -> m Type -> m Con +recGadtC :: Quote m => NonEmpty Name -> [m VarStrictType] -> m Type -> m Con recGadtC cons varstrtys ty = liftA2 (RecGadtC cons) (sequenceA varstrtys) ty ------------------------------------------------------------------------------- @@ -1177,7 +1177,7 @@ docCons :: (Q Con, Maybe String, [Maybe String]) -> Q () docCons (c, md, arg_docs) = do c' <- c -- Attach docs to the constructors - sequence_ [ putDoc (DeclDoc nm) d | Just d <- [md], nm <- get_cons_names c' ] + sequence_ [ putDoc (DeclDoc nm) d | Just d <- [md], nm <- toList $ get_cons_names c' ] -- Attach docs to the arguments case c' of -- Record selector documentation isn't stored in the argument map, @@ -1188,18 +1188,6 @@ docCons (c, md, arg_docs) = do ] _ -> sequence_ [ putDoc (ArgDoc nm i) arg_doc - | nm <- get_cons_names c' + | nm <- toList $ get_cons_names c' , (i, Just arg_doc) <- zip [0..] arg_docs ] - where - get_cons_names :: Con -> [Name] - get_cons_names (NormalC n _) = [n] - get_cons_names (RecC n _) = [n] - get_cons_names (InfixC _ n _) = [n] - get_cons_names (ForallC _ _ cons) = get_cons_names cons - -- GadtC can have multiple names, e.g - -- > data Bar a where - -- > MkBar1, MkBar2 :: a -> Bar a - -- Will have one GadtC with [MkBar1, MkBar2] as names - get_cons_names (GadtC ns _ _) = ns - get_cons_names (RecGadtC ns _ _) = ns diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index cedb974976..d3101a985b 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -11,6 +11,7 @@ module Language.Haskell.TH.Ppr where import Text.PrettyPrint (render) import Language.Haskell.TH.PprLib import Language.Haskell.TH.Syntax +import qualified Data.List.NonEmpty as NE ( toList ) import Data.Word ( Word8 ) import Data.Char ( toLower, chr) import GHC.Show ( showMultiLineString ) @@ -682,22 +683,22 @@ instance Ppr Con where <+> pprName' Infix c <+> pprBangType st2 - ppr (ForallC ns ctxt (GadtC c sts ty)) - = commaSepApplied c <+> dcolon <+> pprForall ns ctxt + ppr (ForallC ns ctxt (GadtC cs sts ty)) + = commaSepApplied (NE.toList cs) <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty - ppr (ForallC ns ctxt (RecGadtC c vsts ty)) - = commaSepApplied c <+> dcolon <+> pprForall ns ctxt + ppr (ForallC ns ctxt (RecGadtC cs vsts ty)) + = commaSepApplied (NE.toList cs) <+> dcolon <+> pprForall ns ctxt <+> pprRecFields vsts ty ppr (ForallC ns ctxt con) = pprForall ns ctxt <+> ppr con - ppr (GadtC c sts ty) - = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty + ppr (GadtC cs sts ty) + = commaSepApplied (NE.toList cs) <+> dcolon <+> pprGadtRHS sts ty - ppr (RecGadtC c vsts ty) - = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty + ppr (RecGadtC cs vsts ty) + = commaSepApplied (NE.toList cs) <+> dcolon <+> pprRecFields vsts ty instance Ppr PatSynDir where ppr Unidir = text "<-" diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 8be340bf93..6668273a14 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -48,6 +48,7 @@ import System.IO ( hPutStrLn, stderr ) import Data.Char ( isAlpha, isAlphaNum, isUpper, ord ) import Data.Int import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE ( singleton ) import Data.Void ( Void, absurd ) import Data.Word import Data.Ratio @@ -1498,8 +1499,9 @@ dataToExpQ = dataToQa varOrConE litE (foldl appE) -- See #10796. varOrConE s = case nameSpace s of - Just VarName -> return (VarE s) - Just DataName -> return (ConE s) + Just VarName -> return (VarE s) + Just (FldName {}) -> return (VarE s) + Just DataName -> return (ConE s) _ -> error $ "Can't construct an expression from name " ++ showName s appE x y = do { a <- x; b <- y; return (AppE a b)} @@ -1675,6 +1677,14 @@ data NameSpace = VarName -- ^ Variables | DataName -- ^ Data constructors | TcClsName -- ^ Type constructors and classes; Haskell has them -- in the same name space for now. + | FldName + { fldParent :: !String + -- ^ The textual name of the parent of the field. + -- + -- - For a field of a datatype, this is the name of the first constructor + -- of the datatype (regardless of whether this constructor has this field). + -- - For a field of a pattern synonym, this is the name of the pattern synonym. + } deriving( Eq, Ord, Show, Data, Generic ) -- | @Uniq@ is used by GHC to distinguish names from each other. @@ -1834,6 +1844,13 @@ mkNameG_v = mkNameG VarName mkNameG_tc = mkNameG TcClsName mkNameG_d = mkNameG DataName +mkNameG_fld :: String -- ^ package + -> String -- ^ module + -> String -- ^ parent (first constructor of parent type) + -> String -- ^ field name + -> Name +mkNameG_fld pkg modu con occ = mkNameG (FldName con) pkg modu occ + data NameIs = Alone | Applied | Infix showName :: Name -> String @@ -1857,11 +1874,11 @@ showName' ni nm -- We may well want to distinguish them in the end. -- Ditto NameU and NameL nms = case nm of - Name occ NameS -> occString occ - Name occ (NameQ m) -> modString m ++ "." ++ occString occ - Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ - Name occ (NameU u) -> occString occ ++ "_" ++ show u - Name occ (NameL u) -> occString occ ++ "_" ++ show u + Name occ NameS -> occString occ + Name occ (NameQ m) -> modString m ++ "." ++ occString occ + Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ + Name occ (NameU u) -> occString occ ++ "_" ++ show u + Name occ (NameL u) -> occString occ ++ "_" ++ show u pnam = classify nms @@ -2705,10 +2722,10 @@ data Con = NormalC Name [BangType] -- ^ @C Int a@ | RecC Name [VarBangType] -- ^ @C { v :: Int, w :: a }@ | InfixC BangType Name BangType -- ^ @Int :+ a@ | ForallC [TyVarBndr Specificity] Cxt Con -- ^ @forall a. Eq a => C [a]@ - | GadtC [Name] [BangType] + | GadtC (NonEmpty Name) [BangType] Type -- See Note [GADT return type] -- ^ @C :: a -> b -> T b Int@ - | RecGadtC [Name] [VarBangType] + | RecGadtC (NonEmpty Name) [VarBangType] Type -- See Note [GADT return type] -- ^ @C :: { v :: Int } -> T b Int@ deriving (Show, Eq, Ord, Data, Generic) @@ -2907,3 +2924,15 @@ cmpEq _ = False thenCmp :: Ordering -> Ordering -> Ordering thenCmp EQ o2 = o2 thenCmp o1 _ = o1 + +get_cons_names :: Con -> NonEmpty Name +get_cons_names (NormalC n _) = NE.singleton n +get_cons_names (RecC n _) = NE.singleton n +get_cons_names (InfixC _ n _) = NE.singleton n +get_cons_names (ForallC _ _ con) = get_cons_names con +-- GadtC can have multiple names, e.g +-- > data Bar a where +-- > MkBar1, MkBar2 :: a -> Bar a +-- Will have one GadtC with [MkBar1, MkBar2] as names +get_cons_names (GadtC ns _ _) = ns +get_cons_names (RecGadtC ns _ _) = ns
\ No newline at end of file diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 8382efd1fc..821c776d96 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -1,5 +1,17 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) +## 2.21.0.0 + + * The `GadtC` and `RecGadtC` constructors of the `Con` datatype now take + non-empty lists of constructors. This means that the `gadtC` and `recGadtC` + smart constructors also expect non-empty lists as arguments. + + * Record fields now belong to separate `NameSpace`s, keyed by the parent of + the record field. This is the name of the first constructor of the parent type, + even if this constructor does not have the field in question. + + This change enables TemplateHaskell support for `DuplicateRecordFields`. + ## 2.20.0.0 * The `Ppr.pprInfixT` function has gained a `Precedence` argument. |