th-desugar 1.16 → 1.17
raw patch · 17 files changed
+479/−35 lines, 17 filesdep ~template-haskell
Dependency ranges changed: template-haskell
Files
- CHANGES.md +34/−0
- Language/Haskell/TH/Desugar.hs +3/−1
- Language/Haskell/TH/Desugar/AST.hs +33/−3
- Language/Haskell/TH/Desugar/Core.hs +24/−2
- Language/Haskell/TH/Desugar/FV.hs +11/−8
- Language/Haskell/TH/Desugar/Match.hs +7/−0
- Language/Haskell/TH/Desugar/Reify.hs +5/−1
- Language/Haskell/TH/Desugar/Sweeten.hs +26/−1
- Language/Haskell/TH/Desugar/Util.hs +92/−6
- README.md +90/−0
- Test/Dec.hs +5/−0
- Test/DsDec.hs +5/−0
- Test/FakeSums.hs +14/−0
- Test/FakeTuples.hs +12/−4
- Test/Run.hs +66/−2
- Test/Splices.hs +43/−0
- th-desugar.cabal +9/−7
CHANGES.md view
@@ -1,6 +1,40 @@ `th-desugar` release notes ========================== +Version 1.17 [2024.05.12]+-------------------------+* Support GHC 9.10.+* Add support namespace identifiers in fixity declarations. As part of these+ changes, the `DInfixD` data constructor now has a `NamespaceSpecifier` field.+* Add support for `SCC` declarations via the new `DSCCP` data constructor for+ the `DPragma` data type.+* Add partial support for embedded types in expressions (via the new `DTypeE`+ data constructor) and in patterns (via the new `DTypeP` data constructor).+ This is only partial support because the use of `DTypeP` is supported in the+ clauses of function declarations, but not in lambda expressions, `\case`+ expressions, or `\cases` expressions. See the "Known limitations" section of+ the `th-desugar` `README` for full details.+* Add partial support for invisible type patterns via the new `DInvisP` data+ constructor. Just like with `DTypeP`, `th-desugar` only supports the use of+ `DInvisP` in the clauses of function declarations. See the "Known limitations"+ section of the `th-desugar` `README` for full details.+* `extractBoundNamesDPat` no longer extracts type variables from constructor+ patterns. That this function ever did extract type variables was a mistake,+ and the new behavior of `extractBoundNamesDPat` brings it in line with the+ behavior `extractBoundNamesPat`.+* The `unboxedTupleNameDegree_maybe` function now returns:+ * `Just 0` when the argument is `''Unit#`+ * `Just 1` when the argument is `''Solo#`+ * `Just <N>` when the argument is `''Tuple<N>#`+ This is primarily motivated by the fact that with GHC 9.10 or later, `''(##)`+ is syntactic sugar for `''Unit#`, `''(#,#)` is syntactic sugar for `Tuple2#`,+ and so on.+* The `unboxedSumNameDegree_maybe` function now returns `Just n` when the+ argument is `Sum<N>#`. This is primarily motivated by the fact that with GHC+ 9.10 or later, `''(#|#)` is syntactic sugar for `Sum2#`, `''(#||#)` is+ syntactic sugar for `Sum3#`, and so on.+* Add `Foldable` and `Traversable` instances for `DTyVarBndrSpec`.+ Version 1.16 [2023.10.13] ------------------------- * Support GHC 9.8.
Language/Haskell/TH/Desugar.hs view
@@ -24,7 +24,7 @@ module Language.Haskell.TH.Desugar ( -- * Desugared data types- DExp(..), DLetDec(..), DPat(..),+ DExp(..), DLetDec(..), NamespaceSpecifier(..), DPat(..), DType(..), DForallTelescope(..), DKind, DCxt, DPred, DTyVarBndr(..), DTyVarBndrSpec, DTyVarBndrUnit, Specificity(..), DTyVarBndrVis,@@ -247,6 +247,8 @@ DBangP pa -> DBangP (wildify name y pa) DSigP pa ty -> DSigP (wildify name y pa) ty DWildP -> DWildP+ DTypeP ty -> DTypeP ty+ DInvisP ty -> DInvisP ty flattenDValD other_dec = return [other_dec]
Language/Haskell/TH/Desugar/AST.hs view
@@ -6,7 +6,7 @@ constructors are prefixed with a D. -} -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, DeriveLift #-}+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveTraversable, DeriveGeneric, DeriveLift #-} module Language.Haskell.TH.Desugar.AST where @@ -37,6 +37,7 @@ | DStaticE DExp | DTypedBracketE DExp | DTypedSpliceE DExp+ | DTypeE DType deriving (Eq, Show, Data, Generic, Lift) @@ -48,6 +49,20 @@ | DBangP DPat | DSigP DPat DType | DWildP+ -- | Note that @th-desugar@ only has partial support for desugaring+ -- embedded type patterns. In particular, @th-desugar@ supports+ -- desugaring embedded type patterns in function clauses, but not+ -- in lambda expressions, @\\case@ expressions, or @\\cases@+ -- expressions. See the \"Known limitations\" section of the+ -- @th-desugar@ @README@ for more details.+ | DTypeP DType+ -- | Note that @th-desugar@ only has partial support for desugaring+ -- invisible type patterns. In particular, @th-desugar@ supports+ -- desugaring invisible type patterns in function clauses, but not+ -- in lambda expressions or @\\cases@ expressions. See the \"Known+ -- limitations\" section of the @th-desugar@ @README@ for more+ -- details.+ | DInvisP DType deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Type@ type, used to represent@@ -88,7 +103,7 @@ data DTyVarBndr flag = DPlainTV Name flag | DKindedTV Name flag DKind- deriving (Eq, Show, Data, Generic, Functor, Lift)+ deriving (Eq, Show, Data, Generic, Functor, Foldable, Traversable, Lift) -- | Corresponds to TH's @TyVarBndrSpec@ type DTyVarBndrSpec = DTyVarBndr Specificity@@ -111,10 +126,24 @@ data DLetDec = DFunD Name [DClause] | DValD DPat DExp | DSigD Name DType- | DInfixD Fixity Name+ | DInfixD Fixity NamespaceSpecifier Name | DPragmaD DPragma deriving (Eq, Show, Data, Generic, Lift) +#if __GLASGOW_HASKELL__ < 909+-- | Same as @NamespaceSpecifier@ from TH; defined here for backwards+-- compatibility.+data NamespaceSpecifier+ = NoNamespaceSpecifier -- ^ Name may be everything; If there are two+ -- names in different namespaces, then consider both+ | TypeNamespaceSpecifier -- ^ Name should be a type-level entity, such as a+ -- data type, type alias, type family, type class,+ -- or type variable+ | DataNamespaceSpecifier -- ^ Name should be a term-level entity, such as a+ -- function, data constructor, or pattern synonym+ deriving (Eq, Ord, Show, Data, Generic, Lift)+#endif+ -- | Corresponds to TH's @Dec@ type. data DDec = DLetDec DLetDec -- | An ordinary (i.e., non-data family) data type declaration. Note@@ -283,6 +312,7 @@ | DLineP Int String | DCompleteP [Name] (Maybe Name) | DOpaqueP Name+ | DSCCP Name (Maybe String) deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @RuleBndr@ type.
Language/Haskell/TH/Desugar/Core.hs view
@@ -266,6 +266,9 @@ dsExp (TypedBracketE exp) = DTypedBracketE <$> dsExp exp dsExp (TypedSpliceE exp) = DTypedSpliceE <$> dsExp exp #endif+#if __GLASGOW_HASKELL__ >= 909+dsExp (TypeE ty) = DTypeE <$> dsType ty+#endif -- | Convert a 'DClause' to a 'DMatch' by bundling all of the clause's patterns -- into a match on a single unboxed tuple pattern. That is, convert this:@@ -649,10 +652,14 @@ dsPat (UnboxedSumP pat alt arity) = DConP (unboxedSumDataName alt arity) [] <$> ((:[]) <$> dsPat pat) #endif+#if __GLASGOW_HASKELL__ >= 909+dsPat (TypeP ty) = DTypeP <$> dsType ty+dsPat (InvisP ty) = DInvisP <$> dsType ty+#endif dsPat (ViewP _ _) = fail "View patterns are not supported in th-desugar. Use pattern guards instead." --- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP'.+-- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP' and 'DInvisP'. dPatToDExp :: DPat -> DExp dPatToDExp (DLitP lit) = DLitE lit dPatToDExp (DVarP name) = DVarE name@@ -660,7 +667,9 @@ dPatToDExp (DTildeP pat) = dPatToDExp pat dPatToDExp (DBangP pat) = dPatToDExp pat dPatToDExp (DSigP pat ty) = DSigE (dPatToDExp pat) ty+dPatToDExp (DTypeP ty) = DTypeE ty dPatToDExp DWildP = error "Internal error in th-desugar: wildcard in rhs of as-pattern"+dPatToDExp (DInvisP {}) = error "Internal error in th-desugar: invisible type pattern in rhs of as-pattern" -- | Remove all wildcards from a pattern, replacing any wildcard with a fresh -- variable@@ -671,6 +680,8 @@ removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat removeWilds (DBangP pat) = DBangP <$> removeWilds pat removeWilds (DSigP pat ty) = DSigP <$> removeWilds pat <*> pure ty+removeWilds (DTypeP ty) = pure $ DTypeP ty+removeWilds (DInvisP ty) = pure $ DInvisP ty removeWilds DWildP = DVarP <$> newUniqueName "wild" -- | Desugar @Info@@@ -898,7 +909,13 @@ dsLetDec (SigD name ty) = do ty' <- dsType ty return ([DSigD name ty'], id)-dsLetDec (InfixD fixity name) = return ([DInfixD fixity name], id)+#if __GLASGOW_HASKELL__ >= 909+dsLetDec (InfixD fixity ns_spec name) =+ return ([DInfixD fixity ns_spec name], id)+#else+dsLetDec (InfixD fixity name) =+ return ([DInfixD fixity NoNamespaceSpecifier name], id)+#endif dsLetDec (PragmaD prag) = do prag' <- dsPragma prag return ([DPragmaD prag'], id)@@ -1059,6 +1076,9 @@ #if __GLASGOW_HASKELL__ >= 903 dsPragma (OpaqueP n) = return $ DOpaqueP n #endif+#if __GLASGOW_HASKELL__ >= 909+dsPragma (SCCP nm mstr) = return $ DSCCP nm mstr+#endif -- | Desugar a @RuleBndr@. dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr@@ -1520,6 +1540,8 @@ isUniversalPattern (DBangP pat) = isUniversalPattern pat isUniversalPattern (DSigP pat _) = isUniversalPattern pat isUniversalPattern DWildP = return True+isUniversalPattern (DTypeP _) = return True+isUniversalPattern (DInvisP _) = return True -- | Apply one 'DExp' to a list of arguments applyDExp :: DExp -> [DExp] -> DExp
Language/Haskell/TH/Desugar/FV.hs view
@@ -41,18 +41,21 @@ -- | Extract the term variables bound by a 'DPat'. ----- This does /not/ extract any type variables bound by pattern signatures.+-- This does /not/ extract any type variables bound by pattern signatures,+-- constructor patterns, or type patterns. extractBoundNamesDPat :: DPat -> OSet Name extractBoundNamesDPat = go where go :: DPat -> OSet Name- go (DLitP _) = OS.empty- go (DVarP n) = OS.singleton n- go (DConP _ tys pats) = foldMap fvDType tys <> foldMap go pats- go (DTildeP p) = go p- go (DBangP p) = go p- go (DSigP p _) = go p- go DWildP = OS.empty+ go (DLitP _) = OS.empty+ go (DVarP n) = OS.singleton n+ go (DConP _ _ pats) = foldMap go pats+ go (DTildeP p) = go p+ go (DBangP p) = go p+ go (DSigP p _) = go p+ go DWildP = OS.empty+ go (DTypeP _) = OS.empty+ go (DInvisP _) = OS.empty ----- -- Binding forms
Language/Haskell/TH/Desugar/Match.hs view
@@ -61,6 +61,7 @@ scExp e@(DConE {}) = return e scExp e@(DLitE {}) = return e scExp e@(DStaticE {}) = return e+scExp e@(DTypeE {}) = return e -- | Like 'scExp', but for a 'DLetDec'. scLetDec :: DsMonad q => DLetDec -> q DLetDec@@ -162,6 +163,8 @@ DBangP p -> tidy1 v (DBangP p) -- discard ! under ! DSigP p _ -> tidy1 v (DBangP p) -- discard sig under ! DWildP -> return (id, DBangP pat) -- no change+ DTypeP _ -> return (id, DBangP pat) -- no change+ DInvisP _ -> return (id, DBangP pat) -- no change tidy1 v (DSigP pat ty) | no_tyvars_ty ty = tidy1 v pat -- The match-flattener doesn't know how to deal with patterns that mention@@ -178,6 +181,8 @@ no_tyvar_ty (DVarT{}) = False no_tyvar_ty t = gmapQl (&&) True no_tyvars_ty t tidy1 _ DWildP = return (id, DWildP)+tidy1 _ (DTypeP ty) = return (id, DTypeP ty)+tidy1 _ (DInvisP ty) = return (id, DInvisP ty) wrapBind :: Name -> Name -> DExp -> DExp wrapBind new old@@ -256,6 +261,8 @@ patGroup (DBangP {}) = PgBang patGroup (DSigP{}) = error "Internal error in th-desugar (patGroup DSigP)" patGroup DWildP = PgAny+patGroup (DTypeP {}) = PgAny+patGroup (DInvisP {}) = PgAny sameGroup :: PatGroup -> PatGroup -> Bool sameGroup PgAny PgAny = True
Language/Haskell/TH/Desugar/Reify.hs view
@@ -242,7 +242,11 @@ reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity reifyFixityInDecs n = firstMatch match_fixity where- match_fixity (InfixD fixity n') | n `nameMatches` n'+ match_fixity (InfixD fixity+#if __GLASGOW_HASKELL__ >= 909+ _+#endif+ n') | n `nameMatches` n' = Just fixity match_fixity (ClassD _ _ _ _ sub_decs) = firstMatch match_fixity sub_decs match_fixity _ = Nothing
Language/Haskell/TH/Desugar/Sweeten.hs view
@@ -72,6 +72,12 @@ expToTH (DTypedSpliceE {}) = error "Typed Template Haskell splices supported only in GHC 9.8+" #endif+#if __GLASGOW_HASKELL__ >= 909+expToTH (DTypeE ty) = TypeE (typeToTH ty)+#else+expToTH (DTypeE {}) =+ error "Embedded type expressions supported only in GHC 9.10+"+#endif matchToTH :: DMatch -> Match matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) []@@ -88,6 +94,15 @@ patToTH (DBangP pat) = BangP (patToTH pat) patToTH (DSigP pat ty) = SigP (patToTH pat) (typeToTH ty) patToTH DWildP = WildP+#if __GLASGOW_HASKELL__ >= 909+patToTH (DTypeP ty) = TypeP (typeToTH ty)+patToTH (DInvisP ty) = InvisP (typeToTH ty)+#else+patToTH (DTypeP {}) =+ error "Embedded type patterns supported only in GHC 9.10+"+patToTH (DInvisP {}) =+ error "Invisible type patterns supported only in GHC 9.10+"+#endif decsToTH :: [DDec] -> [Dec] decsToTH = map decToTH@@ -218,7 +233,12 @@ letDecToTH (DFunD name clauses) = FunD name (map clauseToTH clauses) letDecToTH (DValD pat exp) = ValD (patToTH pat) (NormalB (expToTH exp)) [] letDecToTH (DSigD name ty) = SigD name (typeToTH ty)-letDecToTH (DInfixD f name) = InfixD f name+letDecToTH (DInfixD f _ns_spec name) =+ InfixD f+#if __GLASGOW_HASKELL__ >= 909+ _ns_spec+#endif+ name letDecToTH (DPragmaD prag) = PragmaD (pragmaToTH prag) conToTH :: DCon -> Con@@ -273,6 +293,11 @@ pragmaToTH (DOpaqueP n) = OpaqueP n #else pragmaToTH (DOpaqueP {}) = error "OPAQUE pragmas only supported in GHC 9.4+"+#endif+#if __GLASGOW_HASKELL__ >= 909+pragmaToTH (DSCCP nm mstr) = SCCP nm mstr+#else+pragmaToTH (DSCCP {}) = error "SCCP pragmas only supported in GHC 9.10+" #endif ruleBndrToTH :: DRuleBndr -> RuleBndr
Language/Haskell/TH/Desugar/Util.hs view
@@ -8,7 +8,7 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric, DeriveLift, RankNTypes, ScopedTypeVariables, TupleSections, AllowAmbiguousTypes,- TemplateHaskellQuotes, TypeApplications #-}+ TemplateHaskellQuotes, TypeApplications, MagicHash #-} module Language.Haskell.TH.Desugar.Util ( newUniqueName,@@ -62,6 +62,10 @@ import Text.Read ( readMaybe ) #endif +#if __GLASGOW_HASKELL__ >= 910+import GHC.Types ( Solo#, Sum2#, Tuple0#, Unit# )+#endif+ ---------------------------------------- -- TH manipulations ----------------------------------------@@ -185,7 +189,7 @@ -- however. namePackage name == namePackage ''Tuple0 , nameModule name == nameModule ''Tuple0- , 'T':'u':'p':'l':'e':n <- nameBase (name)+ , 'T':'u':'p':'l':'e':n <- nameBase name -- This relies on the Read Int instance. This is more permissive than what -- we need, since there are valid Int strings (e.g., "-1") that do not have -- corresponding Tuple<N> names (e.g., "Tuple-1" is not a data type in@@ -212,8 +216,36 @@ unboxedSumDegree_maybe = unboxedSumTupleDegree_maybe '|' -- | Extract the degree of an unboxed sum 'Name'.+--+-- In addition to recognizing unboxed sum syntax (e.g., @''(#||#)@), this also+-- recognizes @''Sum<N>#@ (for unboxed <N>-ary sum type constructors). In recent+-- versions of GHC, @''Sum2#@ is a synonym for @''(#|#)@, @''Sum3#@ is a synonym+-- for @''(#||#)@, and so on. As a result, we must check for @''Sum<N>#@ in+-- 'unboxedSumNameDegree_maybe' to be thorough. unboxedSumNameDegree_maybe :: Name -> Maybe Int-unboxedSumNameDegree_maybe = unboxedSumDegree_maybe . nameBase+unboxedSumNameDegree_maybe name+#if __GLASGOW_HASKELL__ >= 910+ -- Check for Sum<N>#. It is theoretically possible for the supplied+ -- Name to be a user-defined data type named Sum<N>#, rather than the actual+ -- unboxed sum types defined in GHC.Types. As such, we check that the package+ -- and module for the supplied Name does in fact come from ghc-prim:GHC.Types+ -- as a sanity check.+ | -- We use Sum2# here simply because it is a convenient identifier from+ -- GHC.Types. We could just as well use any other identifier from GHC.Types,+ -- however.+ namePackage name == namePackage ''Sum2#+ , nameModule name == nameModule ''Sum2#+ , 'S':'u':'m':n:"#" <- nameBase name+ -- This relies on the Read Int instance. This is more permissive than what+ -- we need, since there are valid Int strings (e.g., "-1") that do not have+ -- corresponding Sum<N># names (e.g., "Sum-1#" is not a data type in+ -- GHC.Types). As such, we depend on the assumption that the input string+ -- does in fact come from GHC.Types, which we check above.+ = readMaybe [n]+#endif+ -- ...otherwise, fall back on unboxed sum syntax.+ | otherwise+ = unboxedSumDegree_maybe (nameBase name) -- | Extract the degree of an unboxed tuple unboxedTupleDegree_maybe :: String -> Maybe Int@@ -230,8 +262,49 @@ return degree -- | Extract the degree of an unboxed tuple 'Name'.+--+-- In addition to recognizing unboxed tuple syntax (e.g., @''(#,,#)@), this also+-- recognizes the following:+--+-- * @''Unit#@ (for unboxed 0-tuples)+--+-- * @''Solo#@/@'Solo#@ (for unboxed 1-tuples)+--+-- * @''Tuple<N>#@ (for unboxed <N>-tuples)+--+-- In recent versions of GHC, @''(##)@ is a synonym for @''Unit#@, @''(#,#)@ is+-- a synonym for @''Tuple2#@, and so on. As a result, we must check for+-- @''Unit#@, and @''Tuple<N>@ in 'unboxedTupleNameDegree_maybe' to be thorough.+-- (There is no special unboxed tuple type constructor for @''Solo#@/@'Solo#@,+-- but we check them here as well for the sake of completeness.) unboxedTupleNameDegree_maybe :: Name -> Maybe Int-unboxedTupleNameDegree_maybe = unboxedTupleDegree_maybe . nameBase+unboxedTupleNameDegree_maybe name+#if __GLASGOW_HASKELL__ >= 910+ -- First, check for Solo#...+ | name == ''Solo# = Just 1+ -- ...then, check for Unit#...+ | name == ''Unit# = Just 0+ -- ...then, check for Tuple<N>#. It is theoretically possible for the supplied+ -- Name to be a user-defined data type named Tuple<N>#, rather than the actual+ -- unboxed tuple types defined in GHC.Types. As such, we check that the+ -- package and module for the supplied Name does in fact come from+ -- ghc-prim:GHC.Types as a sanity check.+ | -- We use Tuple0# here simply because it is a convenient identifier from+ -- GHC.Types. We could just as well use any other identifier from GHC.Types,+ -- however.+ namePackage name == namePackage ''Tuple0#+ , nameModule name == nameModule ''Tuple0#+ , 'T':'u':'p':'l':'e':n:"#" <- nameBase name+ -- This relies on the Read Int instance. This is more permissive than what+ -- we need, since there are valid Int strings (e.g., "-1") that do not have+ -- corresponding Tuple<N># names (e.g., "Tuple-1#" is not a data type in+ -- GHC.Types). As such, we depend on the assumption that the input string+ -- does in fact come from GHC.Types, which we check above.+ = readMaybe [n]+#endif+ -- ...otherwise, fall back on unboxed tuple syntax.+ | otherwise+ = unboxedTupleDegree_maybe (nameBase name) -- | If the argument is a tuple type, return the components splitTuple_maybe :: Type -> Maybe [Type]@@ -481,7 +554,10 @@ allNamesIn :: Data a => a -> [Name] allNamesIn = everything (++) $ mkQ [] (:[]) --- | Extract the names bound in a @Stmt@+-- | Extract the names bound in a @Stmt@.+--+-- This does /not/ extract any type variables bound by pattern signatures,+-- constructor patterns, or type patterns. extractBoundNamesStmt :: Stmt -> OSet Name extractBoundNamesStmt (BindS pat _) = extractBoundNamesPat pat extractBoundNamesStmt (LetS decs) = foldMap extractBoundNamesDec decs@@ -492,12 +568,18 @@ #endif -- | Extract the names bound in a @Dec@ that could appear in a @let@ expression.+--+-- This does /not/ extract any type variables bound by pattern signatures,+-- constructor patterns, or type patterns. extractBoundNamesDec :: Dec -> OSet Name extractBoundNamesDec (FunD name _) = OS.singleton name extractBoundNamesDec (ValD pat _ _) = extractBoundNamesPat pat extractBoundNamesDec _ = OS.empty --- | Extract the names bound in a @Pat@+-- | Extract the names bound in a @Pat@.+--+-- This does /not/ extract any type variables bound by pattern signatures,+-- constructor patterns, or type patterns. extractBoundNamesPat :: Pat -> OSet Name extractBoundNamesPat (LitP _) = OS.empty extractBoundNamesPat (VarP name) = OS.singleton name@@ -525,6 +607,10 @@ extractBoundNamesPat (ViewP _ pat) = extractBoundNamesPat pat #if __GLASGOW_HASKELL__ >= 801 extractBoundNamesPat (UnboxedSumP pat _ _) = extractBoundNamesPat pat+#endif+#if __GLASGOW_HASKELL__ >= 909+extractBoundNamesPat (TypeP _) = OS.empty+extractBoundNamesPat (InvisP _) = OS.empty #endif ----------------------------------------
README.md view
@@ -144,3 +144,93 @@ way that linear types interact with Template Haskell, which sometimes make it impossible to tell whether a reified function type is linear or not. See, for instance, [GHC#18378](https://gitlab.haskell.org/ghc/ghc/-/issues/18378).++## Limited support for embedded types in patterns++In GHC 9.10 or later, the `RequiredTypeArguments` language extension allows one+to write definitions with embedded types in patterns, e.g.,++```hs+idv :: forall a -> a -> a+idv (type a) = id @a+```++`th-desugar` supports writing patterns like `(type a)` via the `DTypeP` data+constructor of `DPat`. Be warned, however, that `th-desugar` only supports+desugaring `DTypeP` in the clauses of function declarations, such as the+declaration of `idv` above. As a result, `th-desugar` does not support+desugaring `DTypeP` in any other position, including:++* Lambda expressions. For example, the following is not supported:++ ```hs+ idv2 :: forall a -> a -> a+ idv2 = \(type a) -> id @a+ ```+* `\case` expressions. For example, the following is not supported:++ ```hs+ idv3 :: forall a -> a -> a+ idv3 = \case+ (type a) -> id @a+ ```+* `\cases` expressions. For example, the following is not supported:++ ```hs+ idv4 :: forall a -> a -> a+ idv4 = \cases+ (type a) x -> x :: a+ ```++Note that all of the example above use an explicit `type` keyword, but the same+considerations apply for embedded type patterns that do not use the `type`+keyword. That is, `th-desugar` supports desugaring the following:++```hs+idv' :: forall a -> a -> a+idv' a = id @a+```++But `th-desugar` does not support desugaring any of the following:++```hs+idv2' :: forall a -> a -> a+idv2' = \a -> id @a++idv3' :: forall a -> a -> a+idv3' = \case+ a -> id @a++idv4' :: forall a -> a -> a+idv4' = \cases+ a x -> x :: a+```++As a workaround, one can convert uses of lambdas and `LambdaCase` to function+declarations, which are fully supported. See also [this `th-desugar`+issue](https://github.com/goldfirere/th-desugar/issues/210), which proposes a+different approach to desugaring that would allow all of the examples above to+be accepted.++## Limited support for invisible type patterns++In GHC 9.10 or later, the `TypeAbstractions` language extension allows one to+write definitions with invisible type patterns, e.g.,++```hs+f :: a -> a+f @a = id @a+```++`th-desugar` supports writing patterns like `@a` via the `DInvisP` data+constructor of `DPat`. Be warned, however, that `th-desugar` only supports+desugaring `DInvisP` in the clauses of function declarations, such as the+declaration of `f` above. As a result, `th-desugar` does not support desugaring+`DInvisP` in any other position, such as lambda expressions or `\cases`+expressions.++Ultimately, this limitation has the same underlying cause as `th-desugar`'s+limitations surrounding embedded types in patterns (see the "Limited support+for embedded types in patterns" section above). As a result, the same+workaround applies: convert uses of lambdas and `LambdaCase` to function+declarations, which are fully supported.
Test/Dec.hs view
@@ -54,6 +54,11 @@ $(S.dectest19) #endif +#if __GLASGOW_HASKELL__ >= 909+$(S.dectest20)+$(S.dectest21)+#endif+ $(fmap unqualify S.instance_test) $(fmap unqualify S.imp_inst_test1)
Test/DsDec.hs view
@@ -79,6 +79,11 @@ $(dsDecSplice S.dectest19) #endif +#if __GLASGOW_HASKELL__ >= 909+$(dsDecSplice S.dectest20)+$(dsDecSplice S.dectest21)+#endif+ $(do decs <- S.rec_sel_test withLocalDeclarations decs $ do [DDataD nd [] name [DPlainTV tvbName THAbs.BndrReq] k cons []] <- dsDecs decs
+ Test/FakeSums.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE MagicHash #-}++-- | Defines data types with names identical to those found in "GHC.Types".+-- This is used as part of a series of unit tests for the+-- @unboxedSumNameDegree_maybe@ function, which should only return 'Just' when the+-- argument 'Name' is actually an unboxed sum from "GHC.Types", not a user-defined+-- type.+module FakeSums+ ( Sum2#, Sum3#, Sum4#+ ) where++data Sum2# a b+data Sum3# a b c+data Sum4# a b c
Test/FakeTuples.hs view
@@ -1,13 +1,21 @@+{-# LANGUAGE MagicHash #-}+ -- | Defines data types with names identical to those found in "GHC.Tuple". -- This is used as part of a series of unit tests for the--- @tupleNameDegree_maybe@ function, which should only return 'Just' when the--- argument 'Name' is actually a tuple from "GHC.Tuple", not a user-defined--- type.+-- @tupleNameDegree_maybe@ and @unboxedTupleNameDegree_maybe@ functions, which+-- should only return 'Just' when the argument 'Name' is actually a tuple from+-- "GHC.Tuple", not a user-defined type. module FakeTuples- ( Tuple0, Tuple1, Tuple2, Tuple3+ ( Tuple0, Tuple1, Tuple2, Tuple3+ , Tuple0#, Tuple1#, Tuple2#, Tuple3# ) where data Tuple0 data Tuple1 a data Tuple2 a b data Tuple3 a b c++data Tuple0#+data Tuple1# a+data Tuple2# a b+data Tuple3# a b c
Test/Run.hs view
@@ -10,7 +10,7 @@ FlexibleInstances, ExistentialQuantification, ScopedTypeVariables, GADTs, ViewPatterns, TupleSections, TypeOperators, PartialTypeSignatures, PatternSynonyms,- TypeApplications #-}+ TypeApplications, MagicHash #-} {-# OPTIONS -Wno-incomplete-patterns -Wno-overlapping-patterns -Wno-unused-matches -Wno-type-defaults -Wno-missing-signatures -Wno-unused-do-bind@@ -38,6 +38,10 @@ {-# LANGUAGE TypeAbstractions #-} #endif +#if __GLASGOW_HASKELL__ >= 909+{-# LANGUAGE RequiredTypeArguments #-}+#endif+ module Main where import Prelude hiding ( exp )@@ -82,6 +86,11 @@ import GHC.Tuple ( Tuple0, Tuple1, Tuple2, Tuple3, Unit ) #endif +#if __GLASGOW_HASKELL__ >= 910+import qualified FakeSums+import GHC.Types (Solo#, Sum2#, Sum3#, Sum4#, Tuple0#, Tuple1#, Tuple2#, Tuple3#, Unit#)+#endif+ -- | -- Convert a HUnit test suite to a spec. This can be used to run existing -- HUnit tests with Hspec.@@ -180,6 +189,11 @@ , "typed_th_bracket" ~: $$($test57_typed_th_bracket) @=? $$($(dsSplice test57_typed_th_bracket)) , "typed_th_splice" ~: $test58_typed_th_splice @=? $(dsSplice test58_typed_th_splice) #endif+#if __GLASGOW_HASKELL__ >= 909+ , "embedded_types_keyword" ~: $test59_embedded_types_keyword @=? $(dsSplice test59_embedded_types_keyword)+ , "embedded_types_no_keyword" ~: $test60_embedded_types_no_keyword @=? $(dsSplice test60_embedded_types_no_keyword)+ , "invis_type_pat" ~: $test61_invis_type_pat @=? $(dsSplice test61_invis_type_pat)+#endif ] test35a = $test35_expand@@ -436,7 +450,7 @@ -- -- We define this by hand to avoid GHC#17608 on pre-9.0 GHCs. decs = sweeten [ DClassD [] c [DPlainTV a THAbs.BndrReq] []- [ DLetDec (DInfixD fixity m)+ [ DLetDec (DInfixD fixity NoNamespaceSpecifier m) , DLetDec (DSigD m (DVarT a)) ] ]@@ -634,6 +648,9 @@ , (''(,), Just 2) , (''(,,), Just 3) , (''Maybe, Nothing)+ , (tupleTypeName 0, Just 0)+ , (tupleTypeName 2, Just 2)+ , (tupleTypeName 3, Just 3) #if __GLASGOW_HASKELL__ >= 900 , (''Solo, Just 1) #if __GLASGOW_HASKELL__ >= 906@@ -671,6 +688,50 @@ toposortKindVarsOfTvbs [DKindedTV a1 () (DVarT a2), DKindedTV a2 () (DVarT a1)] == [DPlainTV a2 ()] +-- Unit tests for unboxedTupleNameDegree_maybe and unboxedSumNameDegree_maybe.+-- These also act as a regression test for #213.+test_t213 :: [Bool]+test_t213 =+ map (\(s, expected) -> unboxedTupleNameDegree_maybe s == expected)+ [ (''(##), Just 0)+ , (''(#,#), Just 2)+ , (''(#,,#), Just 3)+ , (''Maybe, Nothing)+#if __GLASGOW_HASKELL__ >= 802+ , (unboxedTupleTypeName 0, Just 0)+#endif+ , (unboxedTupleTypeName 2, Just 2)+ , (unboxedTupleTypeName 3, Just 3)+#if __GLASGOW_HASKELL__ >= 910+ , (''Unit#, Just 0)+ , (''Tuple0#, Just 0)+ , (''Solo#, Just 1)+ , (''Tuple1#, Just 1)+ , (''Tuple2#, Just 2)+ , (''Tuple3#, Just 3)+ , (''FakeTuples.Tuple0#, Nothing)+ , (''FakeTuples.Tuple1#, Nothing)+ , (''FakeTuples.Tuple2#, Nothing)+ , (''FakeTuples.Tuple3#, Nothing)+#endif+ ]+#if __GLASGOW_HASKELL__ >= 802+ +++ map (\(s, expected) -> unboxedSumNameDegree_maybe s == expected)+ [ (unboxedSumTypeName 2, Just 2)+ , (unboxedSumTypeName 3, Just 3)+ , (unboxedSumTypeName 4, Just 4)+#if __GLASGOW_HASKELL__ >= 910+ , (''Sum2#, Just 2)+ , (''Sum3#, Just 3)+ , (''Sum4#, Just 4)+ , (''FakeSums.Sum2#, Nothing)+ , (''FakeSums.Sum3#, Nothing)+ , (''FakeSums.Sum4#, Nothing)+#endif+ ]+#endif+ -- Unit tests for functions that compute free variables (e.g., fvDType) test_fvs :: [Bool] test_fvs =@@ -909,6 +970,9 @@ test_t187 [1..] it "computes free kind variables correctly in a telescope that uses shadowing" $ test_t188++ zipWithM (\b n -> it ("recognizes unboxed {tuple,sum} names with unboxed{Tuple,Sum}Degree_maybe correctly " ++ show n) b)+ test_t213 [1..] -- Remove map pprints here after switch to th-orphans zipWithM (\t t' -> it ("can do Type->DType->Type of " ++ t) $ t == t')
Test/Splices.hs view
@@ -57,6 +57,10 @@ {-# LANGUAGE TypeAbstractions #-} #endif +#if __GLASGOW_HASKELL__ >= 909+{-# LANGUAGE RequiredTypeArguments #-}+#endif+ {-# OPTIONS_GHC -Wno-missing-signatures -Wno-type-defaults -Wno-name-shadowing #-} @@ -391,6 +395,26 @@ typedSpliceE (typedBracketE [| 'y' |]) #endif +#if __GLASGOW_HASKELL__ >= 909+test59_embedded_types_keyword =+ [| let idv :: forall a -> a -> a+ idv (type a) (x :: a) = x :: a++ in idv (type Bool) True |]++test60_embedded_types_no_keyword =+ [| let idv :: forall a -> a -> a+ idv a (x :: a) = x :: a++ in idv Bool True |]++test61_invis_type_pat =+ [| let f :: a -> a+ f @a = id @a++ in f @Bool True |]+#endif+ type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a]@@ -545,6 +569,20 @@ data Dec19 @k (a :: k) = MkDec19 k (Proxy a) |] #endif +#if __GLASGOW_HASKELL__ >= 909+dectest20 = [d| infixr 3 data !@#+ infixr 3 type !@#++ (!@#) :: Bool -> Bool -> Bool+ (!@#) = (&&)++ type family (!@#) :: Bool -> Bool -> Bool |]++dectest21 = [d| {-# SCC dec21 "dec21" #-}+ dec21 :: a -> a+ dec21 x = x |]+#endif+ instance_test = [d| instance (Show a, Show b) => Show (a -> b) where show _ = "function" |] @@ -841,5 +879,10 @@ #if __GLASGOW_HASKELL__ >= 907 , test57_typed_th_bracket , test58_typed_th_splice+#endif+#if __GLASGOW_HASKELL__ >= 909+ , test59_embedded_types_keyword+ , test60_embedded_types_no_keyword+ , test61_invis_type_pat #endif ]
th-desugar.cabal view
@@ -1,5 +1,5 @@ name: th-desugar-version: 1.16+version: 1.17 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell homepage: https://github.com/goldfirere/th-desugar@@ -19,10 +19,11 @@ , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2- , GHC == 9.2.7- , GHC == 9.4.7- , GHC == 9.6.2- , GHC == 9.8.1+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.4+ , GHC == 9.8.2+ , GHC == 9.10.1 description: This package provides the Language.Haskell.TH.Desugar module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding.@@ -48,12 +49,12 @@ build-depends: base >= 4.9 && < 5, ghc-prim,- template-haskell >= 2.11 && < 2.22,+ template-haskell >= 2.11 && < 2.23, containers >= 0.5, mtl >= 2.1 && < 2.4, ordered-containers >= 0.2.2, syb >= 0.4,- th-abstraction >= 0.6 && < 0.7,+ th-abstraction >= 0.6 && < 0.8, th-orphans >= 0.13.7, transformers-compat >= 0.6.3 default-extensions: TemplateHaskell@@ -84,6 +85,7 @@ main-is: Run.hs other-modules: Dec DsDec+ FakeSums FakeTuples ReifyTypeCUSKs ReifyTypeSigs