th-desugar 1.12 → 1.13
raw patch · 13 files changed
+217/−103 lines, 13 filesdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: template-haskell
API changes (from Hackage documentation)
- Language.Haskell.TH.Desugar: DConP :: Name -> [DPat] -> DPat
+ Language.Haskell.TH.Desugar: DConP :: Name -> [DType] -> [DPat] -> DPat
Files
- CHANGES.md +25/−0
- Language/Haskell/TH/Desugar.hs +2/−3
- Language/Haskell/TH/Desugar/AST.hs +7/−1
- Language/Haskell/TH/Desugar/Core.hs +50/−20
- Language/Haskell/TH/Desugar/FV.hs +7/−7
- Language/Haskell/TH/Desugar/Match.hs +15/−15
- Language/Haskell/TH/Desugar/Reify.hs +6/−5
- Language/Haskell/TH/Desugar/Subst.hs +2/−2
- Language/Haskell/TH/Desugar/Sweeten.hs +18/−34
- Language/Haskell/TH/Desugar/Util.hs +5/−1
- Test/Run.hs +28/−2
- Test/Splices.hs +48/−10
- th-desugar.cabal +4/−3
CHANGES.md view
@@ -1,6 +1,31 @@ `th-desugar` release notes ========================== +Version 1.13 [2021.10.30]+-------------------------+* Support GHC 9.2.+* Add support for visible type application in data constructor patterns. As a+ result of these changes, the `DConP` constructor now has an extra field to+ represent type arguments:++ ```diff+ data DPat+ = ...+ - | DConP Name [DPat] -- fun (Just x) = ...+ + | DConP Name [DType] [DPat] -- fun (Just @t x) = ...+ | ...+ ```+* Add support for the `e.field` and `(.field)` syntax from the+ `OverloadedRecordDot` language extension.+* The `Maybe [DTyVarBndrUnit]` fields in `DInstanceD` and `DStandaloneDerivD`+ are no longer used when sweetening. Previously, `th-desugar` would attempt to+ sweeten these `DTyVarBndrUnit`s by turning them into a nested `ForallT`, but+ GHC 9.2 or later no longer allow this, as they forbid nested `forall`s in+ instance heads entirely. As a result, the `Maybe [DTyVarBndrUnit]` fields are+ now only useful for functions that consume `DDec`s directly.+* Fix a bug in which desugared GADT constructors would sometimes incorrectly+ claim that they were declared infix, despite this not being the case.+ Version 1.12 [2021.03.12] ------------------------- * Support GHC 9.0.
Language/Haskell/TH/Desugar.hs view
@@ -136,7 +136,6 @@ import Control.Monad import qualified Data.Foldable as F import Data.Function-import Data.List import qualified Data.Map as M import qualified Data.Set as S import Prelude hiding ( exp )@@ -240,7 +239,7 @@ DVarP n | n == name -> DVarP y | otherwise -> DWildP- DConP con ps -> DConP con (map (wildify name y) ps)+ DConP con ts ps -> DConP con ts (map (wildify name y) ps) DTildeP pa -> DTildeP (wildify name y pa) DBangP pa -> DBangP (wildify name y pa) DSigP pa ty -> DSigP (wildify name y pa) ty@@ -297,7 +296,7 @@ return $ concat [ [ DSigD name $ DForallT (DForallInvis con_tvbs) $ DArrowT `DAppT` con_ret_ty `DAppT` field_ty- , DFunD name [DClause [DConP con_name+ , DFunD name [DClause [DConP con_name [] (mk_field_pats n (length fields) varName)] (DVarE varName)] ] | ((name, _strict, field_ty), n) <- zip fields [0..]
Language/Haskell/TH/Desugar/AST.hs view
@@ -34,7 +34,7 @@ -- | Corresponds to TH's @Pat@ type. data DPat = DLitP Lit | DVarP Name- | DConP Name [DPat]+ | DConP Name [DType] [DPat] | DTildeP DPat | DBangP DPat | DSigP DPat DType@@ -113,6 +113,9 @@ | DDataD NewOrData DCxt Name [DTyVarBndrUnit] (Maybe DKind) [DCon] [DDerivClause] | DTySynD Name [DTyVarBndrUnit] DType | DClassD DCxt Name [DTyVarBndrUnit] [FunDep] [DDec]+ -- | Note that the @Maybe [DTyVarBndrUnit]@ field is dropped+ -- entirely when sweetened, so it is only useful for functions+ -- that directly consume @DDec@s. | DInstanceD (Maybe Overlap) (Maybe [DTyVarBndrUnit]) DCxt DType [DDec] | DForeignD DForeign | DOpenTypeFamilyD DTypeFamilyHead@@ -122,6 +125,9 @@ [DCon] [DDerivClause] | DTySynInstD DTySynEqn | DRoleAnnotD Name [Role]+ -- | Note that the @Maybe [DTyVarBndrUnit]@ field is dropped+ -- entirely when sweetened, so it is only useful for functions+ -- that directly consume @DDec@s. | DStandaloneDerivD (Maybe DDerivStrategy) (Maybe [DTyVarBndrUnit]) DCxt DType | DDefaultSigD Name DType | DPatSynD Name PatSynArgs DPatSynDir DPat
Language/Haskell/TH/Desugar/Core.hs view
@@ -28,6 +28,7 @@ import Data.Data (Data, Typeable) import Data.Either (lefts) import Data.Foldable as F hiding (concat, notElem)+import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as M import Data.Map (Map) import Data.Maybe (mapMaybe)@@ -50,6 +51,10 @@ import GHC.Classes (IP(..)) #endif +#if __GLASGOW_HASKELL__ >= 902+import GHC.Records (HasField(..))+#endif+ import GHC.Exts import GHC.Generics (Generic) @@ -89,8 +94,15 @@ dsExp (TupE exps) = dsTup tupleDataName exps dsExp (UnboxedTupE exps) = dsTup unboxedTupleDataName exps dsExp (CondE e1 e2 e3) =- dsExp (CaseE e1 [ Match (ConP 'True []) (NormalB e2) []- , Match (ConP 'False []) (NormalB e3) [] ])+ dsExp (CaseE e1 [mkBoolMatch 'True e2, mkBoolMatch 'False e3])+ where+ mkBoolMatch :: Name -> Exp -> Match+ mkBoolMatch boolDataCon rhs =+ Match (ConP boolDataCon+#if __GLASGOW_HASKELL__ >= 901+ []+#endif+ []) (NormalB rhs) [] dsExp (MultiIfE guarded_exps) = let failure = DAppE (DVarE 'error) (DLitE (StringL "Non-exhaustive guards in multi-way if")) in dsGuards guarded_exps failure@@ -213,7 +225,7 @@ rec_con_to_dmatch con_name args = do let con_field_names = map fst_of_3 args field_var_names <- mapM (newUniqueName . nameBase) con_field_names- DMatch (DConP con_name (map DVarP field_var_names)) <$>+ DMatch (DConP con_name [] (map DVarP field_var_names)) <$> (foldl DAppE (DConE con_name) <$> (reorderFields con_name args field_exps (map DVarE field_var_names))) @@ -249,6 +261,15 @@ dsExp (ImplicitParamVarE n) = return $ DVarE 'ip `DAppTypeE` DLitT (StrTyLit n) dsExp (MDoE {}) = fail "th-desugar currently does not support RecursiveDo" #endif+#if __GLASGOW_HASKELL__ >= 902+dsExp (GetFieldE arg field) = DAppE (mkGetFieldProj field) <$> dsExp arg+dsExp (ProjectionE fields) =+ case fields of+ f :| fs -> return $ foldl' comp (mkGetFieldProj f) fs+ where+ comp :: DExp -> String -> DExp+ comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc+#endif #if __GLASGOW_HASKELL__ >= 809 dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp@@ -310,6 +331,11 @@ stripDVarP_maybe (DVarP n) = Just n stripDVarP_maybe _ = Nothing +#if __GLASGOW_HASKELL__ >= 902+mkGetFieldProj :: String -> DExp+mkGetFieldProj field = DVarE 'getField `DAppTypeE` DLitT (StrTyLit field)+#endif+ -- | Desugar a list of matches for a @case@ statement dsMatches :: DsMonad q => Name -- ^ Name of the scrutinee, which must be a bare var@@ -396,8 +422,8 @@ dsGuardStmts (NoBindS exp : rest) success failure = do exp' <- dsExp exp success' <- dsGuardStmts rest success failure- return $ DCaseE exp' [ DMatch (DConP 'True []) success'- , DMatch (DConP 'False []) failure ]+ return $ DCaseE exp' [ DMatch (DConP 'True [] []) success'+ , DMatch (DConP 'False [] []) failure ] dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard." #if __GLASGOW_HASKELL__ >= 807 dsGuardStmts (RecS {} : _) _ _ = fail "th-desugar currently does not support RecursiveDo"@@ -514,7 +540,7 @@ (rest_pat, rest_exp) <- dsParComp rest dsQ <- dsComp (q ++ [mk_tuple_stmt qv]) let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp- return (DConP (tupleDataName 2) [mk_tuple_dpat qv, rest_pat], zipped)+ return (DConP (tupleDataName 2) [] [mk_tuple_dpat qv, rest_pat], zipped) -- helper function for dsParComp mk_tuple_stmt :: OSet Name -> Stmt@@ -555,11 +581,15 @@ dsPat :: DsMonad q => Pat -> PatM q DPat dsPat (LitP lit) = return $ DLitP lit dsPat (VarP n) = return $ DVarP n-dsPat (TupP pats) = DConP (tupleDataName (length pats)) <$> mapM dsPat pats-dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) <$>+dsPat (TupP pats) = DConP (tupleDataName (length pats)) [] <$> mapM dsPat pats+dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) [] <$> mapM dsPat pats-dsPat (ConP name pats) = DConP name <$> mapM dsPat pats-dsPat (InfixP p1 name p2) = DConP name <$> mapM dsPat [p1, p2]+#if __GLASGOW_HASKELL__ >= 901+dsPat (ConP name tys pats) = DConP name <$> mapM dsType tys <*> mapM dsPat pats+#else+dsPat (ConP name pats) = DConP name [] <$> mapM dsPat pats+#endif+dsPat (InfixP p1 name p2) = DConP name [] <$> mapM dsPat [p1, p2] dsPat (UInfixP _ _ _) = fail "Cannot desugar unresolved infix operators." dsPat (ParensP pat) = dsPat pat@@ -574,7 +604,7 @@ dsPat (RecP con_name field_pats) = do con <- lift $ dataConNameToCon con_name reordered <- reorder con- return $ DConP con_name reordered+ return $ DConP con_name [] reordered where reorder con = case con of NormalC _name fields -> non_record fields@@ -601,15 +631,15 @@ ++ (show con_name) ++ "." dsPat (ListP pats) = go pats- where go [] = return $ DConP '[] []+ where go [] = return $ DConP '[] [] [] go (h : t) = do h' <- dsPat h t' <- go t- return $ DConP '(:) [h', t']+ return $ DConP '(:) [] [h', t'] dsPat (SigP pat ty) = DSigP <$> dsPat pat <*> dsType ty #if __GLASGOW_HASKELL__ >= 801 dsPat (UnboxedSumP pat alt arity) =- DConP (unboxedSumDataName alt arity) <$> ((:[]) <$> dsPat pat)+ DConP (unboxedSumDataName alt arity) [] <$> ((:[]) <$> dsPat pat) #endif dsPat (ViewP _ _) = fail "View patterns are not supported in th-desugar. Use pattern guards instead."@@ -618,7 +648,7 @@ dPatToDExp :: DPat -> DExp dPatToDExp (DLitP lit) = DLitE lit dPatToDExp (DVarP name) = DVarE name-dPatToDExp (DConP name pats) = foldl DAppE (DConE name) (map dPatToDExp pats)+dPatToDExp (DConP name tys pats) = foldl DAppE (foldl DAppTypeE (DConE name) tys) (map dPatToDExp pats) dPatToDExp (DTildeP pat) = dPatToDExp pat dPatToDExp (DBangP pat) = dPatToDExp pat dPatToDExp (DSigP pat ty) = DSigE (dPatToDExp pat) ty@@ -629,7 +659,7 @@ removeWilds :: DsMonad q => DPat -> q DPat removeWilds p@(DLitP _) = return p removeWilds p@(DVarP _) = return p-removeWilds (DConP con_name pats) = DConP con_name <$> mapM removeWilds pats+removeWilds (DConP con_name tys pats) = DConP con_name tys <$> mapM removeWilds pats removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat removeWilds (DBangP pat) = DBangP <$> removeWilds pat removeWilds (DSigP pat ty) = DSigP <$> removeWilds pat <*> pure ty@@ -1021,8 +1051,8 @@ -- properties hold: let decInfix = isInfixDataCon (nameBase nm) -- 1. Its name uses operator syntax -- (e.g., (:*:))- || length dbtys == 2 -- 2. It has exactly two fields- || isJust mbFi -- 3. It has a programmer-specified+ && length dbtys == 2 -- 2. It has exactly two fields+ && isJust mbFi -- 3. It has a programmer-specified -- fixity declaration return (nm, [], [], DNormalC decInfix dbtys, Just drty) dsCon' (RecGadtC nms vbtys rty) = do@@ -1444,13 +1474,13 @@ -- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. mkTupleDPat :: [DPat] -> DPat mkTupleDPat [pat] = pat-mkTupleDPat pats = DConP (tupleDataName (length pats)) pats+mkTupleDPat pats = DConP (tupleDataName (length pats)) [] pats -- | Is this pattern guaranteed to match? isUniversalPattern :: DsMonad q => DPat -> q Bool isUniversalPattern (DLitP {}) = return False isUniversalPattern (DVarP {}) = return True-isUniversalPattern (DConP con_name pats) = do+isUniversalPattern (DConP con_name _ pats) = do data_name <- dataConNameToDataName con_name (_tvbs, cons) <- getDataD "Internal error." data_name if length cons == 1
Language/Haskell/TH/Desugar/FV.hs view
@@ -49,13 +49,13 @@ extractBoundNamesDPat = go where go :: DPat -> OSet Name- 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 (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 ----- -- Binding forms
Language/Haskell/TH/Desugar/Match.hs view
@@ -150,7 +150,7 @@ case pat of DLitP _ -> tidy1 v pat -- already strict DVarP _ -> return (id, DBangP pat) -- no change- DConP _ _ -> tidy1 v pat -- already strict+ DConP{} -> tidy1 v pat -- already strict DTildeP p -> tidy1 v (DBangP p) -- discard ~ under ! DBangP p -> tidy1 v (DBangP p) -- discard ! under ! DSigP p _ -> tidy1 v (DBangP p) -- discard sig under !@@ -215,7 +215,7 @@ -> q DExp mk_projection tup_name i = do var_name <- newUniqueName "proj"- return $ DCaseE (DVarE tup_name) [DMatch (DConP (tupleDataName tuple_size) (mk_tuple_pats var_name i))+ return $ DCaseE (DVarE tup_name) [DMatch (DConP (tupleDataName tuple_size) [] (mk_tuple_pats var_name i)) (DVarE var_name)] mk_tuple_pats :: Name -- of the projected element@@ -242,13 +242,13 @@ (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 patGroup :: DPat -> PatGroup-patGroup (DLitP l) = PgLit l-patGroup (DVarP {}) = error "Internal error in th-desugar (patGroup DVarP)"-patGroup (DConP con _) = PgCon con-patGroup (DTildeP {}) = error "Internal error in th-desugar (patGroup DTildeP)"-patGroup (DBangP {}) = PgBang-patGroup (DSigP{}) = error "Internal error in th-desugar (patGroup DSigP)"-patGroup DWildP = PgAny+patGroup (DLitP l) = PgLit l+patGroup (DVarP {}) = error "Internal error in th-desugar (patGroup DVarP)"+patGroup (DConP con _ _) = PgCon con+patGroup (DTildeP {}) = error "Internal error in th-desugar (patGroup DTildeP)"+patGroup (DBangP {}) = PgBang+patGroup (DSigP{}) = error "Internal error in th-desugar (patGroup DSigP)"+patGroup DWildP = PgAny sameGroup :: PatGroup -> PatGroup -> Bool sameGroup PgAny PgAny = True@@ -292,17 +292,17 @@ where pat1 = firstPat eqn1 - pat_args (DConP _ pats) = pats- pat_args _ = error "Internal error in th-desugar (pat_args)"+ pat_args (DConP _ _ pats) = pats+ pat_args _ = error "Internal error in th-desugar (pat_args)" - pat_con (DConP con _) = con- pat_con _ = error "Internal error in th-desugar (pat_con)"+ pat_con (DConP con _ _) = con+ pat_con _ = error "Internal error in th-desugar (pat_con)" match_group :: DsMonad q => [Name] -> q MatchResult match_group arg_vars = simplCase (arg_vars ++ vars) (map shift eqns) - shift (EquationInfo (DConP _ args : pats) exp) = EquationInfo (args ++ pats) exp+ shift (EquationInfo (DConP _ _ args : pats) exp) = EquationInfo (args ++ pats) exp shift _ = error "Internal error in th-desugar (shift)" matchOneCon _ _ = error "Internal error in th-desugar (matchOneCon)" @@ -315,7 +315,7 @@ where mk_alt fail (CaseAlt con args body_fn) = let body = body_fn fail in- DMatch (DConP con (map DVarP args)) body+ DMatch (DConP con [] (map DVarP args)) body mk_default all_ctors fail | exhaustive_case all_ctors = [] | otherwise = [DMatch DWildP fail]
Language/Haskell/TH/Desugar/Reify.hs view
@@ -44,7 +44,7 @@ import Data.Foldable (foldMap) #endif import Data.Function (on)-import Data.List+import qualified Data.List as List import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe@@ -172,7 +172,7 @@ -- the constructor to get the tycon, and then reify the tycon to get the `Con`s type_name <- dataConNameToDataName con_name (_, cons) <- getDataD "This seems to be an error in GHC." type_name- let m_con = find (any (con_name ==) . get_con_name) cons+ let m_con = List.find (any (con_name ==) . get_con_name) cons case m_con of Just con -> return con Nothing -> impossible "Datatype does not contain one of its own constructors."@@ -256,7 +256,8 @@ reifyInDec :: Name -> [Dec] -> Dec -> Maybe (Named Info) reifyInDec n decs (FunD n' _) | n `nameMatches` n' = Just (n', mkVarI n decs) reifyInDec n decs (ValD pat _ _)- | Just n' <- find (nameMatches n) (F.toList (extractBoundNamesPat pat)) = Just (n', mkVarI n decs)+ | Just n' <- List.find (nameMatches n) (F.toList (extractBoundNamesPat pat))+ = Just (n', mkVarI n decs) #if __GLASGOW_HASKELL__ > 710 reifyInDec n _ dec@(DataD _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) reifyInDec n _ dec@(NewtypeD _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec)@@ -671,7 +672,7 @@ meth_tvbs :: [TyVarBndrSpec] meth_tvbs = changeTVFlags SpecifiedSpec $- deleteFirstsBy ((==) `on` tvName)+ List.deleteFirstsBy ((==) `on` tvName) (freeVariablesWellScoped [meth_ty]) all_cls_tvbs -- Explicitly quantify any kind variables bound by the class, if any.@@ -718,7 +719,7 @@ #if __GLASGOW_HASKELL__ > 710 gadt_case :: Con -> [Name] -> Maybe (Named Con)- gadt_case con nms = case find (n `nameMatches`) nms of+ gadt_case con nms = case List.find (n `nameMatches`) nms of Just n' -> Just (n', con) Nothing -> Nothing #endif
Language/Haskell/TH/Desugar/Subst.hs view
@@ -24,7 +24,7 @@ IgnoreKinds(..), matchTy ) where -import Data.List+import qualified Data.List as L import qualified Data.Map as M import qualified Data.Set as S @@ -140,7 +140,7 @@ matchTy _ _ _ = Nothing unionMaybeSubsts :: [Maybe DSubst] -> Maybe DSubst-unionMaybeSubsts = foldl' union_subst1 (Just M.empty)+unionMaybeSubsts = L.foldl' union_subst1 (Just M.empty) where union_subst1 :: Maybe DSubst -> Maybe DSubst -> Maybe DSubst union_subst1 ma mb = do
Language/Haskell/TH/Desugar/Sweeten.hs view
@@ -43,7 +43,7 @@ import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Desugar.AST-import Language.Haskell.TH.Desugar.Core (DTypeArg(..), changeDTVFlags)+import Language.Haskell.TH.Desugar.Core (DTypeArg(..)) import Language.Haskell.TH.Desugar.Util expToTH :: DExp -> Exp@@ -72,13 +72,17 @@ matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) [] patToTH :: DPat -> Pat-patToTH (DLitP lit) = LitP lit-patToTH (DVarP n) = VarP n-patToTH (DConP n pats) = ConP n (map patToTH pats)-patToTH (DTildeP pat) = TildeP (patToTH pat)-patToTH (DBangP pat) = BangP (patToTH pat)-patToTH (DSigP pat ty) = SigP (patToTH pat) (typeToTH ty)-patToTH DWildP = WildP+patToTH (DLitP lit) = LitP lit+patToTH (DVarP n) = VarP n+patToTH (DConP n _tys pats) = ConP n+#if __GLASGOW_HASKELL__ >= 901+ (map typeToTH _tys)+#endif+ (map patToTH pats)+patToTH (DTildeP pat) = TildeP (patToTH pat)+patToTH (DBangP pat) = BangP (patToTH pat)+patToTH (DSigP pat ty) = SigP (patToTH pat) (typeToTH ty)+patToTH DWildP = WildP decsToTH :: [DDec] -> [Dec] decsToTH = map decToTH@@ -108,19 +112,9 @@ decToTH (DTySynD n tvbs ty) = TySynD n (map tvbToTH tvbs) (typeToTH ty) decToTH (DClassD cxt n tvbs fds decs) = ClassD (cxtToTH cxt) n (map tvbToTH tvbs) fds (decsToTH decs)-decToTH (DInstanceD over mtvbs _cxt _ty decs) =- instanceDToTH over cxt' ty' decs- where- (cxt', ty') = case fmap (changeDTVFlags SpecifiedSpec) mtvbs of- Nothing -> (_cxt, _ty)- Just _tvbs ->-#if __GLASGOW_HASKELL__ < 800 || __GLASGOW_HASKELL__ >= 802- ([], DForallT (DForallInvis _tvbs) $ DConstrainedT _cxt _ty)-#else- -- See #117- error $ "Explicit foralls in instance declarations "- ++ "are broken on GHC 8.0."-#endif+decToTH (DInstanceD over _mtvbs cxt ty decs) =+ -- We deliberately avoid sweetening _mtvbs. See #151.+ instanceDToTH over cxt ty decs decToTH (DForeignD f) = ForeignD (foreignToTH f) #if __GLASGOW_HASKELL__ > 710 decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs ann)) =@@ -157,19 +151,9 @@ ClosedTypeFamilyD n (map tvbToTH tvbs) (frsToTH frs) (map (snd . tySynEqnToTH) eqns) #endif decToTH (DRoleAnnotD n roles) = RoleAnnotD n roles-decToTH (DStandaloneDerivD mds mtvbs _cxt _ty) =- standaloneDerivDToTH mds cxt' ty'- where- (cxt', ty') = case fmap (changeDTVFlags SpecifiedSpec) mtvbs of- Nothing -> (_cxt, _ty)- Just _tvbs ->-#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 802- ([], DForallT (DForallInvis _tvbs) $ DConstrainedT _cxt _ty)-#else- -- See #117- error $ "Explicit foralls in standalone deriving declarations "- ++ "are broken on GHC 7.10 and 8.0."-#endif+decToTH (DStandaloneDerivD mds _mtvbs cxt ty) =+ -- We deliberately avoid sweetening _mtvbs. See #151.+ standaloneDerivDToTH mds cxt ty #if __GLASGOW_HASKELL__ < 709 decToTH (DDefaultSigD {}) = error "Default method signatures supported only in GHC 7.10+"
Language/Haskell/TH/Desugar/Util.hs view
@@ -417,7 +417,11 @@ extractBoundNamesPat (VarP name) = OS.singleton name extractBoundNamesPat (TupP pats) = foldMap extractBoundNamesPat pats extractBoundNamesPat (UnboxedTupP pats) = foldMap extractBoundNamesPat pats-extractBoundNamesPat (ConP _ pats) = foldMap extractBoundNamesPat pats+extractBoundNamesPat (ConP _+#if __GLASGOW_HASKELL__ >= 901+ _+#endif+ pats) = foldMap extractBoundNamesPat pats extractBoundNamesPat (InfixP p1 _ p2) = extractBoundNamesPat p1 `OS.union` extractBoundNamesPat p2 extractBoundNamesPat (UInfixP p1 _ p2) = extractBoundNamesPat p1 `OS.union`
Test/Run.hs view
@@ -13,7 +13,7 @@ {-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns -fno-warn-unused-matches -fno-warn-type-defaults -fno-warn-missing-signatures -fno-warn-unused-do-bind- -fno-warn-missing-fields #-}+ -fno-warn-missing-fields -fno-warn-incomplete-record-updates #-} #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE PartialTypeSignatures #-}@@ -151,6 +151,12 @@ #if __GLASGOW_HASKELL__ >= 900 , "qual_do" ~: $test52_qual_do @=? $(dsSplice test52_qual_do) #endif+#if __GLASGOW_HASKELL__ >= 901+ , "vta_in_con_pats" ~: $test53_vta_in_con_pats @=? $(dsSplice test53_vta_in_con_pats)+#endif+#if __GLASGOW_HASKELL__ >= 902+ , "overloaded_record_dot" ~: $test54_overloaded_record_dot @=? $(dsSplice test54_overloaded_record_dot)+#endif ] test35a = $test35_expand@@ -358,7 +364,7 @@ Just (DVarI _ actual_ty _) -> exp_ty `eqTHSplice` actual_ty _ -> [| False |]) #else- True -- RecGadtC didn't exist prior to GHC 8.0, do the quote above will+ True -- RecGadtC didn't exist prior to GHC 8.0, so the quote above will -- normalize to `data T b = MkT { unT :: b }`. This defeats the point of -- this test, and to make things worse, this will cause `dsReify` to -- return a different type for unT (forall b. T b -> b). Let's just not@@ -439,6 +445,24 @@ actual <- withLocalDeclarations decs (reifyFixityWithLocals m) expected `eqTHSplice` actual) +test_t154 :: Bool+test_t154 =+#if __GLASGOW_HASKELL__ >= 800+ $(do decs <- [d| data T where+ (:$$:) :: Int -> Int -> T+ |]+ ddecs <- dsDecs decs+ let mb_is_infix = case ddecs of+ [DDataD _ _ _ _ _ [DCon _ _ _ (DNormalC is_infix _) _] _]+ -> Just is_infix+ _ -> Nothing+ mb_is_infix `eqTHSplice` Just False)+#else+ True -- GadtC didn't exist prior to GHC 8.0, so the quote above will+ -- normalize to `data T = (:$$:) Int Int`. This defeats the point of+ -- this test, so let's just not bother testing this on pre-8.0 GHCs.+#endif+ -- Unit tests for functions that compute free variables (e.g., fvDType) test_fvs :: [Bool] test_fvs =@@ -645,6 +669,8 @@ zipWithM (\b n -> it ("computes free variables correctly " ++ show n) b) test_fvs [1..]++ it "desugars non-infix GADT constructors with symbolic names correctly" $ test_t154 -- 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
@@ -44,12 +44,16 @@ {-# LANGUAGE QualifiedDo #-} #endif +#if __GLASGOW_HASKELL__ >= 902+{-# LANGUAGE OverloadedRecordDot #-}+#endif+ {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-name-shadowing #-} module Splices where -import Data.List+import qualified Data.List as L import Data.Char import GHC.Exts import GHC.TypeLits@@ -116,7 +120,7 @@ frob str | head str == 'r' = str | head str == 'R' = str- | otherwise = dropWhileEnd isDigit str+ | otherwise = L.dropWhileEnd isDigit str -- Because th-desugar does not support linear types, we must pretend like -- MulArrowT does not exist for testing purposes.@@ -149,8 +153,8 @@ test8_case = [| case Just False of { Just True -> 1 ; Just _ -> 2 ; Nothing -> 3 } |] test9_do = [| show $ do { foo <- Just "foo" ; let fool = foo ++ "l"- ; elemIndex 'o' fool- ; x <- elemIndex 'l' fool+ ; L.elemIndex 'o' fool+ ; x <- L.elemIndex 'l' fool ; return (x + 10) } |] test10_comp = [| [ (x, x+1) | x <- [1..10], x `mod` 2 == 0 ] |] test11_parcomp = [| [ (x,y) | x <- [1..10], x `mod` 2 == 0 | y <- [2,5..20] ] |]@@ -325,6 +329,28 @@ P.return y |] #endif +#if __GLASGOW_HASKELL__ >= 901+test53_vta_in_con_pats =+ [| let f :: Maybe Int -> Int+ f (Just @Int x) = x+ f (Nothing @Int) = 42+ in f (Just @Int 27) |]+#endif++#if __GLASGOW_HASKELL__ >= 902+data ORD1 = MkORD1 { unORD1 :: Int }+data ORD2 = MkORD2 { unORD2 :: ORD1 }++test54_overloaded_record_dot =+ [| let ord1 :: ORD1+ ord1 = MkORD1 1++ ord2 :: ORD2+ ord2 = MkORD2 ord1++ in (ord2.unORD2.unORD1, (.unORD2.unORD1) ord2) |]+#endif+ type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a]@@ -445,6 +471,14 @@ data ExData1 a data ExData2 a +-- ds_dectest{16,17} demonstrate instance declarations with outermost foralls,+-- a feature which Template Haskell itself does not yet support (see #151).+-- For this reason, the closest we can get to this in TH is to construct+-- equivalent Decs, dectest{16,17}, that drop the outermost foralls. The test+-- suite ensures that this process happens automatically during sweetening by+-- checking that the sweetened versions of ds_dectest{16,17} equal+-- dectest{16,17}.+ ds_dectest16 = DInstanceD Nothing (Just [DPlainTV (mkName "a") ()]) [] (DConT ''ExCls `DAppT` (DConT ''ExData1 `DAppT` DVarT (mkName "a"))) []@@ -453,9 +487,8 @@ #if __GLASGOW_HASKELL__ >= 800 Nothing #endif- [] (ForallT [plainTVSpecified (mkName "a")] []- (ConT ''ExCls `AppT`- (ConT ''ExData1 `AppT` VarT (mkName "a")))) [] ]+ [] (ConT ''ExCls `AppT`+ (ConT ''ExData1 `AppT` VarT (mkName "a"))) [] ] ds_dectest17 = DStandaloneDerivD Nothing (Just [DPlainTV (mkName "a") ()]) [] (DConT ''ExCls `DAppT` (DConT ''ExData2 `DAppT` DVarT (mkName "a")))@@ -465,9 +498,8 @@ #if __GLASGOW_HASKELL__ >= 802 Nothing #endif- [] (ForallT [plainTVSpecified (mkName "a")] []- (ConT ''ExCls `AppT`- (ConT ''ExData2 `AppT` VarT (mkName "a")))) ]+ [] (ConT ''ExCls `AppT`+ (ConT ''ExData2 `AppT` VarT (mkName "a"))) ] #endif #if __GLASGOW_HASKELL__ >= 809@@ -763,5 +795,11 @@ #endif #if __GLASGOW_HASKELL__ >= 900 , test52_qual_do+#endif+#if __GLASGOW_HASKELL__ >= 901+ , test53_vta_in_con_pats+#endif+#if __GLASGOW_HASKELL__ >= 902+ , test54_overloaded_record_dot #endif ]
th-desugar.cabal view
@@ -1,5 +1,5 @@ name: th-desugar-version: 1.12+version: 1.13 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell homepage: https://github.com/goldfirere/th-desugar@@ -19,8 +19,9 @@ , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4- , GHC == 8.10.4+ , GHC == 8.10.7 , GHC == 9.0.1+ , GHC == 9.2.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.@@ -46,7 +47,7 @@ build-depends: base >= 4.7 && < 5, ghc-prim,- template-haskell >= 2.9 && < 2.18,+ template-haskell >= 2.9 && < 2.19, containers >= 0.5, mtl >= 2.1, ordered-containers >= 0.2.2,