th-desugar 1.5.5 → 1.6
raw patch · 14 files changed
+822/−270 lines, 14 filesdep +th-expand-synsdep ~basedep ~template-haskell
Dependencies added: th-expand-syns
Dependency ranges changed: base, template-haskell
Files
- CHANGES.md +10/−0
- Language/Haskell/TH/Desugar.hs +41/−41
- Language/Haskell/TH/Desugar/Core.hs +328/−123
- Language/Haskell/TH/Desugar/Expand.hs +7/−3
- Language/Haskell/TH/Desugar/Lift.hs +6/−1
- Language/Haskell/TH/Desugar/Match.hs +7/−7
- Language/Haskell/TH/Desugar/Reify.hs +182/−26
- Language/Haskell/TH/Desugar/Sweeten.hs +130/−30
- Language/Haskell/TH/Desugar/Util.hs +4/−14
- Test/Dec.hs +8/−2
- Test/DsDec.hs +12/−5
- Test/Run.hs +11/−3
- Test/Splices.hs +70/−11
- th-desugar.cabal +6/−4
CHANGES.md view
@@ -1,6 +1,16 @@ `th-desugar` release notes ========================== +Version 1.6+-----------+* Work with GHC 8, with thanks to @christiaanb for getting this change going.+ This means that several core datatypes have changed: partcularly, we now have+ `DTypeFamilyHead` and fixities are now reified separately from other things.++* `DKind` is merged with `DType`.++* `Generic` instances for everything.+ Version 1.5.5 -------------
Language/Haskell/TH/Desugar.hs view
@@ -23,9 +23,13 @@ module Language.Haskell.TH.Desugar ( -- * Desugared data types- DExp(..), DLetDec(..), DPat(..), DType(..), DKind(..), DCxt, DPred(..),- DTyVarBndr(..), DMatch(..), DClause(..), DDec(..), NewOrData(..),- DCon(..), DConFields(..), DStrictType, DVarStrictType, DForeign(..),+ DExp(..), DLetDec(..), DPat(..), DType(..), DKind, DCxt, DPred(..),+ DTyVarBndr(..), DMatch(..), DClause(..), DDec(..),+ Overlap(..), NewOrData(..),+ DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..),+ DCon(..), DConFields(..), DBangType, DVarBangType,+ Bang(..), SourceUnpackedness(..), SourceStrictness(..),+ DForeign(..), DPragma(..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec, Role(..), AnnTarget(..), @@ -33,18 +37,22 @@ Desugar(..), -- * Main desugaring functions- dsExp, dsDecs, dsType, dsKind, dsInfo,+ dsExp, dsDecs, dsType, dsInfo, dsPatOverExp, dsPatsOverExp, dsPatX, dsLetDecs, dsTvb, dsCxt, dsCon, dsForeign, dsPragma, dsRuleBndr, -- ** Secondary desugaring functions PatM, dsPred, dsPat, dsDec, dsLetDec,- dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses, + dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses,+ dsBangType, dsVarBangType,+#if __GLASGOW_HASKELL__ > 710+ dsTypeFamilyHead, dsFamilyResultSig,+#endif -- * Converting desugared AST back to TH AST module Language.Haskell.TH.Desugar.Sweeten,- + -- * Expanding type synonyms expand, expandType, @@ -69,7 +77,8 @@ substTy, tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe,- + strictToBang,+ -- ** Extracting bound names extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat ) where@@ -104,10 +113,6 @@ desugar = dsType sweeten = typeToTH -instance Desugar Kind DKind where- desugar = dsKind- sweeten = kindToTH- instance Desugar Cxt DCxt where desugar = dsCxt sweeten = cxtToTH@@ -120,9 +125,9 @@ desugar = dsDecs sweeten = decsToTH -instance Desugar Con DCon where- desugar = dsCon- sweeten = conToTH+instance Desugar [Con] [DCon] where+ desugar = concatMapM dsCon+ sweeten = map conToTH -- | If the declaration passed in is a 'DValD', creates new, equivalent -- declarations such that the 'DPat' in all 'DValD's is just a plain@@ -156,7 +161,7 @@ DTildePa pa -> DTildePa (wildify name y pa) DBangPa pa -> DBangPa (wildify name y pa) DWildPa -> DWildPa- + flattenDValD other_dec = return [other_dec] extractBoundNamesDPat :: DPat -> S.Set Name@@ -172,48 +177,43 @@ where go (DForallT tvbs _cxt ty) = go ty `S.difference` (foldMap dtvbName tvbs) go (DAppT ty1 ty2) = go ty1 `S.union` go ty2- go (DSigT ty ki) = go ty `S.union` fvDKind ki+ go (DSigT ty ki) = go ty `S.union` fvDType ki go (DVarT n) = S.singleton n go (DConT _) = S.empty go DArrowT = S.empty go (DLitT {}) = S.empty+ go DWildCardT = S.empty+ go DStarT = S.empty dtvbName :: DTyVarBndr -> S.Set Name dtvbName (DPlainTV n) = S.singleton n dtvbName (DKindedTV n _) = S.singleton n -fvDKind :: DKind -> S.Set Name-fvDKind = go- where- go (DForallK names ki) = go ki `S.difference` (S.fromList names)- go (DVarK n) = S.singleton n- go (DConK _ kis) = foldMap fvDKind kis- go (DArrowK k1 k2) = go k1 `S.union` go k2- go DStarK = S.empty- -- | Produces 'DLetDec's representing the record selector functions from -- the provided 'DCon'. getRecordSelectors :: Quasi q => DType -- ^ the type of the argument -> DCon -> q [DLetDec]-getRecordSelectors _ (DCon _ _ _ (DNormalC {})) = return []-getRecordSelectors arg_ty (DCon _ _ con_name (DRecC fields)) = do- varName <- qNewName "field"- let tvbs = fvDType arg_ty- maybe_forall- | S.null tvbs = id- | otherwise = DForallT (map DPlainTV $ S.toList tvbs) []- num_pats = length fields- return $ concat- [ [ DSigD name (maybe_forall $ DArrowT `DAppT` arg_ty `DAppT` res_ty)- , DFunD name [DClause [DConPa con_name (mk_field_pats n num_pats varName)]- (DVarE varName)] ]- | ((name, _strict, res_ty), n) <- zip fields [0..]- , fvDType res_ty `S.isSubsetOf` tvbs -- exclude "naughty" selectors- ] -+getRecordSelectors arg_ty (DCon _ _ con_name con _) = case con of+ DRecC fields -> go fields+ _ -> return [] where+ go fields = do+ varName <- qNewName "field"+ let tvbs = fvDType arg_ty+ maybe_forall+ | S.null tvbs = id+ | otherwise = DForallT (map DPlainTV $ S.toList tvbs) []+ num_pats = length fields+ return $ concat+ [ [ DSigD name (maybe_forall $ DArrowT `DAppT` arg_ty `DAppT` res_ty)+ , DFunD name [DClause [DConPa con_name (mk_field_pats n num_pats varName)]+ (DVarE varName)] ]+ | ((name, _strict, res_ty), n) <- zip fields [0..]+ , fvDType res_ty `S.isSubsetOf` tvbs -- exclude "naughty" selectors+ ]+ mk_field_pats :: Int -> Int -> Name -> [DPat] mk_field_pats 0 total name = DVarPa name : (replicate (total-1) DWildPa) mk_field_pats n total name = DWildPa : mk_field_pats (n-1) (total-1) name
Language/Haskell/TH/Desugar/Core.hs view
@@ -7,7 +7,8 @@ processing. The desugared types and constructors are prefixed with a D. -} -{-# LANGUAGE TemplateHaskell, LambdaCase, CPP, DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell, LambdaCase, CPP, DeriveDataTypeable,+ DeriveGeneric, TupleSections #-} module Language.Haskell.TH.Desugar.Core where @@ -15,6 +16,7 @@ import Language.Haskell.TH hiding (match, clause, cxt) import Language.Haskell.TH.Syntax hiding (lift)+import Language.Haskell.TH.ExpandSyns ( expandSyns ) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative@@ -22,9 +24,10 @@ import Control.Monad hiding (mapM) import Control.Monad.Zip import Control.Monad.Writer hiding (mapM)-import Data.Foldable+import Data.Foldable hiding (notElem) import Data.Traversable import Data.Data hiding (Fixity)+import GHC.Generics hiding (Fixity) import qualified Data.Set as S import GHC.Exts@@ -42,7 +45,7 @@ | DLetE [DLetDec] DExp | DSigE DExp DType | DStaticE DExp- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @Pat@ type.@@ -52,9 +55,10 @@ | DTildePa DPat | DBangPa DPat | DWildPa- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) --- | Corresponds to TH's @Type@ type.+-- | Corresponds to TH's @Type@ type, used to represent+-- types and kinds. data DType = DForallT [DTyVarBndr] DCxt DType | DAppT DType DType | DSigT DType DKind@@ -62,16 +66,12 @@ | DConT Name | DArrowT | DLitT TyLit- deriving (Show, Typeable, Data)+ | DWildCardT+ | DStarT+ deriving (Show, Typeable, Data, Generic) --- | Corresponds to TH's @Kind@ type, which is a synonym for @Type@. 'DKind', though,--- only contains constructors that make sense for kinds.-data DKind = DForallK [Name] DKind- | DVarK Name- | DConK Name [DKind]- | DArrowK DKind DKind- | DStarK- deriving (Show, Typeable, Data)+-- | Kinds are types.+type DKind = DType -- | Corresponds to TH's @Cxt@ type DCxt = [DPred]@@ -81,71 +81,112 @@ | DSigPr DPred DKind | DVarPr Name | DConPr Name- deriving (Show, Typeable, Data)+ | DWildCardPr+ deriving (Show, Typeable, Data, Generic) --- | Corresponds to TH's @TyVarBndr@. Note that @PlainTV x@ and @KindedTV x StarT@ are--- distinct, so we retain that distinction here.+-- | Corresponds to TH's @TyVarBndr@ data DTyVarBndr = DPlainTV Name | DKindedTV Name DKind- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @Match@ type. data DMatch = DMatch DPat DExp- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @Clause@ type. data DClause = DClause [DPat] DExp- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) -- | Declarations as used in a @let@ statement. data DLetDec = DFunD Name [DClause] | DValD DPat DExp | DSigD Name DType | DInfixD Fixity Name- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) -- | Is it a @newtype@ or a @data@ type? data NewOrData = Newtype | Data- deriving (Eq, Show, Typeable, Data)+ deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @Dec@ type. data DDec = DLetDec DLetDec- | DDataD NewOrData DCxt Name [DTyVarBndr] [DCon] [Name]+ | DDataD NewOrData DCxt Name [DTyVarBndr] [DCon] [DPred] | DTySynD Name [DTyVarBndr] DType | DClassD DCxt Name [DTyVarBndr] [FunDep] [DDec]- | DInstanceD DCxt DType [DDec]+ | DInstanceD (Maybe Overlap) DCxt DType [DDec] | DForeignD DForeign | DPragmaD DPragma- | DFamilyD FamFlavour Name [DTyVarBndr] (Maybe DKind)- | DDataInstD NewOrData DCxt Name [DType] [DCon] [Name]+ | DOpenTypeFamilyD DTypeFamilyHead+ | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn]+ | DDataFamilyD Name [DTyVarBndr]+ | DDataInstD NewOrData DCxt Name [DType] [DCon] [DPred] | DTySynInstD Name DTySynEqn- | DClosedTypeFamilyD Name [DTyVarBndr] (Maybe DKind) [DTySynEqn] | DRoleAnnotD Name [Role] | DStandaloneDerivD DCxt DType | DDefaultSigD Name DType- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) +#if __GLASGOW_HASKELL__ < 711+data Overlap = Overlappable | Overlapping | Overlaps | Incoherent+ deriving (Eq, Ord, Show, Typeable, Data, Generic)+#endif++-- | Corresponds to TH's 'TypeFamilyHead' type+data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndr] DFamilyResultSig+ (Maybe InjectivityAnn)+ deriving (Show, Typeable, Data, Generic)++-- | Corresponds to TH's 'FamilyResultSig' type+data DFamilyResultSig = DNoSig+ | DKindSig DKind+ | DTyVarSig DTyVarBndr+ deriving (Show, Typeable, Data, Generic)++#if __GLASGOW_HASKELL__ <= 710+data InjectivityAnn = InjectivityAnn Name [Name]+ deriving (Eq, Ord, Show, Typeable, Data, Generic)+#endif+ -- | Corresponds to TH's @Con@ type. data DCon = DCon [DTyVarBndr] DCxt Name DConFields- deriving (Show, Typeable, Data)+ (Maybe DType) -- ^ A GADT result type, if there is one+ deriving (Show, Typeable, Data, Generic) -- | A list of fields either for a standard data constructor or a record -- data constructor.-data DConFields = DNormalC [DStrictType]- | DRecC [DVarStrictType]- deriving (Show, Typeable, Data)+data DConFields = DNormalC [DBangType]+ | DRecC [DVarBangType]+ deriving (Show, Typeable, Data, Generic) --- | Corresponds to TH's @StrictType@ type.-type DStrictType = (Strict, DType)+-- | Corresponds to TH's @BangType@ type.+type DBangType = (Bang, DType) --- | Corresponds to TH's @VarStrictType@ type.-type DVarStrictType = (Name, Strict, DType)+-- | Corresponds to TH's @VarBangType@ type.+type DVarBangType = (Name, Bang, DType) +#if __GLASGOW_HASKELL__ <= 710+-- | Corresponds to TH's definition+data SourceUnpackedness = NoSourceUnpackedness+ | SourceNoUnpack+ | SourceUnpack+ deriving (Eq, Ord, Show, Typeable, Data, Generic)++-- | Corresponds to TH's definition+data SourceStrictness = NoSourceStrictness+ | SourceLazy+ | SourceStrict+ deriving (Eq, Ord, Show, Typeable, Data, Generic)++-- | Corresponds to TH's definition+data Bang = Bang SourceUnpackedness SourceStrictness+ deriving (Eq, Ord, Show, Typeable, Data, Generic)+#endif+ -- | Corresponds to TH's @Foreign@ type. data DForeign = DImportF Callconv Safety String Name DType | DExportF Callconv String Name DType- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @Pragma@ type. data DPragma = DInlineP Name Inline RuleMatch Phases@@ -154,32 +195,32 @@ | DRuleP String [DRuleBndr] DExp DExp Phases | DAnnP AnnTarget DExp | DLineP Int String- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @RuleBndr@ type. data DRuleBndr = DRuleVar Name | DTypedRuleVar Name DType- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) -- | Corresponds to TH's @TySynEqn@ type (to store type family equations). data DTySynEqn = DTySynEqn [DType] DType- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) #if __GLASGOW_HASKELL__ < 707 -- | Same as @Role@ from TH; defined here for GHC 7.6.3 compatibility. data Role = NominalR | RepresentationalR | PhantomR | InferR- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) -- | Same as @AnnTarget@ from TH; defined here for GHC 7.6.3 compatibility. data AnnTarget = ModuleAnnotation | TypeAnnotation Name | ValueAnnotation Name- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) #endif -- | Corresponds to TH's @Info@ type. data DInfo = DTyConI DDec (Maybe [DInstanceDec])- | DVarI Name DType (Maybe Name) Fixity+ | DVarI Name DType (Maybe Name) -- ^ The @Maybe Name@ stores the name of the enclosing definition -- (datatype, for a data constructor; class, for a method), -- if any@@ -187,7 +228,7 @@ | DPrimTyConI Name Int Bool -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon -- is unlifted.- deriving (Show, Typeable, Data)+ deriving (Show, Typeable, Data, Generic) type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration @@ -267,7 +308,11 @@ _ -> impossible "Record update with no fields listed." info <- reifyWithLocals first_name applied_type <- case info of+#if __GLASGOW_HASKELL__ > 710+ VarI _name ty _m_dec -> extract_first_arg ty+#else VarI _name ty _m_dec _fixity -> extract_first_arg ty+#endif _ -> impossible "Record update with an invalid field name." type_name <- extract_type_name applied_type (_, cons) <- getDataD "This seems to be an error in GHC." type_name@@ -317,6 +362,9 @@ #if __GLASGOW_HASKELL__ >= 709 dsExp (StaticE exp) = DStaticE <$> dsExp exp #endif+#if __GLASGOW_HASKELL__ > 710+dsExp (UnboundVarE n) = return (DVarE n)+#endif -- | Desugar a lambda expression, where the body has already been desugared dsLam :: DsMonad q => [Pat] -> DExp -> q DExp@@ -565,8 +613,12 @@ [ddec] <- dsDec dec dinstances <- dsDecs instances return $ DTyConI ddec (Just dinstances)-dsInfo (ClassOpI name ty parent fixity) =- DVarI name <$> dsType ty <*> pure (Just parent) <*> pure fixity+#if __GLASGOW_HASKELL__ > 710+dsInfo (ClassOpI name ty parent) =+#else+dsInfo (ClassOpI name ty parent _fixity) =+#endif+ DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (TyConI dec) = do [ddec] <- dsDec dec return $ DTyConI ddec Nothing@@ -578,32 +630,49 @@ return $ DTyConI ddec' (Just dinstances') dsInfo (PrimTyConI name arity unlifted) = return $ DPrimTyConI name arity unlifted-dsInfo (DataConI name ty parent fixity) =- DVarI name <$> dsType ty <*> pure (Just parent) <*> pure fixity-dsInfo (VarI name ty Nothing fixity) =- DVarI name <$> dsType ty <*> pure Nothing <*> pure fixity+#if __GLASGOW_HASKELL__ > 710+dsInfo (DataConI name ty parent) =+ DVarI name <$> dsType ty <*> pure (Just parent)+dsInfo (VarI name ty Nothing) =+ DVarI name <$> dsType ty <*> pure Nothing+dsInfo (VarI name _ (Just _)) =+ impossible $ "Declaration supplied with variable: " ++ show name+#else+dsInfo (DataConI name ty parent _fixity) =+ DVarI name <$> dsType ty <*> pure (Just parent)+dsInfo (VarI name ty Nothing _fixity) =+ DVarI name <$> dsType ty <*> pure Nothing dsInfo (VarI name _ (Just _) _) = impossible $ "Declaration supplied with variable: " ++ show name-dsInfo (TyVarI name ty) = DTyVarI name <$> dsKind ty+#endif+dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty fixBug8884ForFamilies :: DsMonad q => DDec -> q (DDec, Int) #if __GLASGOW_HASKELL__ < 708-fixBug8884ForFamilies (DFamilyD flav name tvbs m_kind) = do+fixBug8884ForFamilies (DOpenTypeFamilyD (DTypeFamilyHead name tvbs frs ann)) = do let num_args = length tvbs- m_kind' <- mapM (remove_arrows num_args) m_kind- return (DFamilyD flav name tvbs m_kind', num_args)-fixBug8884ForFamilies (DClosedTypeFamilyD name tvbs m_kind eqns) = do+ frs' <- remove_arrows num_args frs+ return (DOpenTypeFamilyD (DTypeFamilyHead name tvbs frs' ann),num_args)+fixBug8884ForFamilies (DClosedTypeFamilyD (DTypeFamilyHead name tvbs frs ann) eqns) = do let num_args = length tvbs eqns' = map (fixBug8884ForEqn num_args) eqns- m_kind' <- mapM (remove_arrows num_args) m_kind- return (DClosedTypeFamilyD name tvbs m_kind' eqns', num_args)+ frs' <- remove_arrows num_args frs+ return (DClosedTypeFamilyD (DTypeFamilyHead name tvbs frs' ann) eqns', num_args)+fixBug8884ForFamilies dec@(DDataFamilyD _ _)+ = return (dec, 0) -- the num_args is ignored for data families fixBug8884ForFamilies dec = impossible $ "Reifying yielded a FamilyI with a non-family Dec: " ++ show dec -remove_arrows :: DsMonad q => Int -> DKind -> q DKind-remove_arrows 0 k = return k-remove_arrows n (DArrowK _ k) = remove_arrows (n-1) k-remove_arrows _ _ =+remove_arrows :: DsMonad q => Int -> DFamilyResultSig -> q DFamilyResultSig+remove_arrows n (DKindSig k) = DKindSig <$> remove_arrows_kind n k+remove_arrows n (DTyVarSig (DKindedTV nm k)) =+ DTyVarSig <$> (DKindedTV nm <$> remove_arrows_kind n k)+remove_arrows _ frs = return frs++remove_arrows_kind :: DsMonad q => Int -> DKind -> q DKind+remove_arrows_kind 0 k = return k+remove_arrows_kind n (DAppT (DAppT DArrowT _) k) = remove_arrows_kind (n-1) k+remove_arrows_kind _ _ = impossible "Internal error: Fix for bug 8884 ran out of arrows." #else@@ -632,42 +701,94 @@ dsDec :: DsMonad q => Dec -> q [DDec] dsDec d@(FunD {}) = (fmap . map) DLetDec $ dsLetDec d dsDec d@(ValD {}) = (fmap . map) DLetDec $ dsLetDec d+#if __GLASGOW_HASKELL__ > 710+dsDec (DataD cxt n tvbs mk cons derivings) = do+ extra_tvbs <- mkExtraTvbs tvbs mk+ (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n+ <*> ((++ extra_tvbs) <$> mapM dsTvb tvbs)+ <*> concatMapM dsCon cons+ <*> dsCxt derivings)+dsDec (NewtypeD cxt n tvbs mk con derivings) = do+ extra_tvbs <- mkExtraTvbs tvbs mk+ (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n+ <*> ((++ extra_tvbs) <$> mapM dsTvb tvbs)+ <*> dsCon con <*> dsCxt derivings)+#else dsDec (DataD cxt n tvbs cons derivings) = (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n- <*> mapM dsTvb tvbs <*> mapM dsCon cons- <*> pure derivings)+ <*> mapM dsTvb tvbs <*> concatMapM dsCon cons+ <*> pure (map DConPr derivings)) dsDec (NewtypeD cxt n tvbs con derivings) = (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n- <*> mapM dsTvb tvbs <*> ((:[]) <$> dsCon con)- <*> pure derivings)+ <*> mapM dsTvb tvbs <*> dsCon con+ <*> pure (map DConPr derivings))+#endif dsDec (TySynD n tvbs ty) = (:[]) <$> (DTySynD n <$> mapM dsTvb tvbs <*> dsType ty) dsDec (ClassD cxt n tvbs fds decs) = (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvb tvbs <*> pure fds <*> dsDecs decs)+#if __GLASGOW_HASKELL__ >= 711+dsDec (InstanceD over cxt ty decs) =+ (:[]) <$> (DInstanceD <$> pure over <*> dsCxt cxt <*> dsType ty <*> dsDecs decs)+#else dsDec (InstanceD cxt ty decs) =- (:[]) <$> (DInstanceD <$> dsCxt cxt <*> dsType ty <*> dsDecs decs)+ (:[]) <$> (DInstanceD <$> pure Nothing <*> dsCxt cxt <*> dsType ty <*> dsDecs decs)+#endif dsDec d@(SigD {}) = (fmap . map) DLetDec $ dsLetDec d dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f) dsDec d@(InfixD {}) = (fmap . map) DLetDec $ dsLetDec d dsDec (PragmaD prag) = (:[]) <$> (DPragmaD <$> dsPragma prag)-dsDec (FamilyD flav n tvbs m_k) =- (:[]) <$> (DFamilyD flav n <$> mapM dsTvb tvbs <*> mapM dsKind m_k)-dsDec (DataInstD cxt n tys cons derivings) =+#if __GLASGOW_HASKELL__ > 710+dsDec (OpenTypeFamilyD tfHead) =+ (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead)+dsDec (DataFamilyD n tvbs m_k) = do+ extra_tvbs <- mkExtraTvbs tvbs m_k+ (:[]) <$> (DDataFamilyD n <$> ((++ extra_tvbs) <$> mapM dsTvb tvbs))+#else+dsDec (FamilyD TypeFam n tvbs m_k) = do+ (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k)+dsDec (FamilyD DataFam n tvbs m_k) = do+ extra_tvbs <- mkExtraTvbs tvbs m_k+ (:[]) <$> (DDataFamilyD n <$> ((++ extra_tvbs) <$> mapM dsTvb tvbs))+#endif+#if __GLASGOW_HASKELL__ > 710+dsDec (DataInstD cxt n tys mk cons derivings) = do+ extra_tvbs <- map dTyVarBndrToDType <$> mkExtraTvbs [] mk+ (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n+ <*> ((++ extra_tvbs) <$> mapM dsType tys)+ <*> concatMapM dsCon cons+ <*> dsCxt derivings)+dsDec (NewtypeInstD cxt n tys mk con derivings) = do+ extra_tvbs <- map dTyVarBndrToDType <$> mkExtraTvbs [] mk+ (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n+ <*> ((++ extra_tvbs) <$> mapM dsType tys)+ <*> dsCon con+ <*> dsCxt derivings)+#else+dsDec (DataInstD cxt n tys cons derivings) = do (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n <*> mapM dsType tys- <*> mapM dsCon cons <*> pure derivings)-dsDec (NewtypeInstD cxt n tys con derivings) =+ <*> concatMapM dsCon cons+ <*> pure (map DConPr derivings))+dsDec (NewtypeInstD cxt n tys con derivings) = do (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n <*> mapM dsType tys- <*> ((:[]) <$> dsCon con) <*> pure derivings)+ <*> dsCon con <*> pure (map DConPr derivings))+#endif #if __GLASGOW_HASKELL__ < 707 dsDec (TySynInstD n lhs rhs) = (:[]) <$> (DTySynInstD n <$> (DTySynEqn <$> mapM dsType lhs <*> dsType rhs)) #else dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD n <$> dsTySynEqn eqn)-dsDec (ClosedTypeFamilyD n tvbs m_k eqns) =- (:[]) <$> (DClosedTypeFamilyD n <$> mapM dsTvb tvbs <*> mapM dsKind m_k- <*> mapM dsTySynEqn eqns)+#if __GLASGOW_HASKELL__ > 710+dsDec (ClosedTypeFamilyD tfHead eqns) =+ (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead+ <*> mapM dsTySynEqn eqns)+#else+dsDec (ClosedTypeFamilyD n tvbs m_k eqns) = do+ (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k+ <*> mapM dsTySynEqn eqns)+#endif dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles] #endif #if __GLASGOW_HASKELL__ >= 709@@ -676,7 +797,62 @@ dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty) #endif +mkExtraTvbs :: DsMonad q => [TyVarBndr] -> Maybe Kind -> q [DTyVarBndr]+mkExtraTvbs _ Nothing = return []+mkExtraTvbs orig_tvbs (Just k) = do+ k' <- runQ (expandSyns k) -- just in case+ dk <- dsType k'+ let args = split_funs [] dk+ -- christiaanb: I have no idea how GHC normally picks fresh+ -- tyvars, this looks like something GHC might do. Though probably in a+ -- nicer/safer way.+ --+ -- RAE: It's actually not terribly far off from what GHC does. This is+ -- terrible. But I don't see another way to do this. <shudder>+ --+ -- All of this is needed so that "dec test 9" passes.+ orig_names = map (nameBase . tvbName) orig_tvbs+ all_names =+#if __GLASGOW_HASKELL__ <= 708+ map ('$':) $+#endif+ take (length args + length orig_tvbs)+ (map (:[]) ['a' .. 'z'] +++ concatMap (zipWith (:) ['a' .. 'z'] . repeat . show)+ [(0::Int)..])+ new_names = filter (`notElem` orig_names) all_names+ names <- zipWithM (\n _ -> qNewName n) new_names args+ return (zipWith DKindedTV names args)+ where+ split_funs args (DAppT (DAppT DArrowT arg) res) = split_funs (arg:args) res+ split_funs args _other = reverse args +#if __GLASGOW_HASKELL__ > 710+-- | Desugar a @FamilyResultSig@+dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig+dsFamilyResultSig NoSig = return DNoSig+dsFamilyResultSig (KindSig k) = DKindSig <$> dsType k+dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvb tvb++-- | Desugar a @TypeFamilyHead@+dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead+dsTypeFamilyHead (TypeFamilyHead n tvbs result inj)+ = DTypeFamilyHead n <$> mapM dsTvb tvbs+ <*> dsFamilyResultSig result+ <*> pure inj+#else+-- | Desugar bits and pieces into a 'DTypeFamilyHead'+dsTypeFamilyHead :: DsMonad q+ => Name -> [TyVarBndr] -> Maybe Kind -> q DTypeFamilyHead+dsTypeFamilyHead n tvbs m_kind = do+ result_sig <- case m_kind of+ Nothing -> return DNoSig+ Just k -> DKindSig <$> dsType k+ DTypeFamilyHead n <$> mapM dsTvb tvbs+ <*> pure result_sig+ <*> pure Nothing+#endif+ -- | Desugar @Dec@s that can appear in a let expression dsLetDecs :: DsMonad q => [Dec] -> q [DLetDec] dsLetDecs = concatMapM dsLetDec@@ -701,19 +877,53 @@ dsLetDec _dec = impossible "Illegal declaration in let expression." -- | Desugar a single @Con@.-dsCon :: DsMonad q => Con -> q DCon-dsCon (NormalC n stys) = DCon [] [] n <$> (DNormalC <$> mapM (liftSndM dsType) stys)-dsCon (RecC n vstys) = DCon [] [] n <$> (DRecC <$> mapM (liftThdOf3M dsType) vstys)-dsCon (InfixC (s1, ty1) n (s2, ty2)) = do- dty1 <- dsType ty1- dty2 <- dsType ty2- return $ DCon [] [] n (DNormalC [(s1, dty1), (s2, dty2)])+dsCon :: DsMonad q+ => Con -> q [DCon]+dsCon (NormalC n stys) =+ (:[]) <$> (DCon [] [] n <$> (DNormalC <$> mapM dsBangType stys) <*> pure Nothing)+dsCon (RecC n vstys) =+ (:[]) <$> (DCon [] [] n <$> (DRecC <$> mapM dsVarBangType vstys) <*> pure Nothing)+dsCon (InfixC sty1 n sty2) = do+ dty1 <- dsBangType sty1+ dty2 <- dsBangType sty2+ return $ [DCon [] [] n (DNormalC [dty1, dty2]) Nothing] dsCon (ForallC tvbs cxt con) = do dtvbs <- mapM dsTvb tvbs dcxt <- dsCxt cxt- DCon dtvbs' dcxt' n fields <- dsCon con- return $ DCon (dtvbs ++ dtvbs') (dcxt ++ dcxt') n fields+ dcons <- dsCon con+ return $ flip map dcons $ \(DCon dtvbs' dcxt' n fields m_kind) ->+ DCon (dtvbs ++ dtvbs') (dcxt ++ dcxt') n fields m_kind+#if __GLASGOW_HASKELL__ > 710+dsCon (GadtC nms btys rty) = do+ dbtys <- mapM dsBangType btys+ drty <- dsType rty+ return $ flip map nms $ \nm ->+ DCon [] [] nm (DNormalC dbtys) (Just drty)+dsCon (RecGadtC nms vbtys rty) = do+ dvbtys <- mapM dsVarBangType vbtys+ drty <- dsType rty+ return $ flip map nms $ \nm ->+ DCon [] [] nm (DRecC dvbtys) (Just drty)+#endif +#if __GLASGOW_HASKELL__ > 710+-- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned)+dsBangType :: DsMonad q => BangType -> q DBangType+dsBangType (b, ty) = (b, ) <$> dsType ty++-- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned)+dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType+dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty+#else+-- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned)+dsBangType :: DsMonad q => StrictType -> q DBangType+dsBangType (b, ty) = (strictToBang b, ) <$> dsType ty++-- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned)+dsVarBangType :: DsMonad q => VarStrictType -> q DVarBangType+dsVarBangType (n, b, ty) = (n, strictToBang b, ) <$> dsType ty+#endif+ -- | Desugar a @Foreign@. dsForeign :: DsMonad q => Foreign -> q DForeign dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty@@ -785,7 +995,7 @@ dsType :: DsMonad q => Type -> q DType dsType (ForallT tvbs preds ty) = DForallT <$> mapM dsTvb tvbs <*> dsCxt preds <*> dsType ty dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2-dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsKind ki+dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki dsType (VarT name) = return $ DVarT name dsType (ConT name) = return $ DConT name -- the only difference between ConT and PromotedT is the name lookup. Here, we assume@@ -800,17 +1010,23 @@ dsType (PromotedTupleT n) = return $ DConT (tupleDataName n) dsType PromotedNilT = return $ DConT '[] dsType PromotedConsT = return $ DConT '(:)-dsType StarT = impossible "The kind * seen in a type."-dsType ConstraintT = impossible "The kind `Constraint' seen in a type."+dsType StarT = return DStarT+dsType ConstraintT = return $ DConT ''Constraint dsType (LitT lit) = return $ DLitT lit #if __GLASGOW_HASKELL__ >= 709 dsType EqualityT = return $ DConT ''(~) #endif+#if __GLASGOW_HASKELL__ > 710+dsType (InfixT t1 n t2) = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2+dsType (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators."+dsType (ParensT t) = dsType t+dsType WildCardT = return DWildCardT+#endif -- | Desugar a @TyVarBndr@ dsTvb :: DsMonad q => TyVarBndr -> q DTyVarBndr dsTvb (PlainTV n) = return $ DPlainTV n-dsTvb (KindedTV n k) = DKindedTV n <$> dsKind k+dsTvb (KindedTV n k) = DKindedTV n <$> dsType k -- | Desugar a @Cxt@ dsCxt :: DsMonad q => Cxt -> q DCxt@@ -836,7 +1052,7 @@ dsPred (SigT ty ki) = do preds <- dsPred ty case preds of- [p] -> (:[]) <$> DSigPr p <$> dsKind ki+ [p] -> (:[]) <$> DSigPr p <$> dsType ki other -> return other -- just drop the kind signature on a tuple. dsPred (VarT n) = return [DVarPr n] dsPred (ConT n) = return [DConPr n]@@ -859,41 +1075,12 @@ dsPred t@(LitT _) = impossible $ "Type literal seen as head of constraint: " ++ show t dsPred EqualityT = return [DConPr ''(~)]+#if __GLASGOW_HASKELL__ > 710+dsPred (InfixT t1 n t2) = (:[]) <$> (DAppPr <$> (DAppPr (DConPr n) <$> dsType t1) <*> dsType t2)+dsPred (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators."+dsPred (ParensT t) = dsPred t+dsPred WildCardT = return [DWildCardPr] #endif---- | Desugar a kind-dsKind :: DsMonad q => Kind -> q DKind-dsKind (ForallT tvbs cxt ki)- | [] <- cxt- , Just names <- mapM stripPlainTV_maybe tvbs- = DForallK names <$> dsKind ki-- | otherwise- = impossible "Annotations of kind variables or kind constraints."-dsKind (AppT (AppT ArrowT k1) k2) = DArrowK <$> dsKind k1 <*> dsKind k2-dsKind (AppT k1 k2) = do- k1' <- dsKind k1- (con_name, args) <- case k1' of- DConK n as -> return (n, as)- _ -> impossible "Illegal kind application."- k2' <- dsKind k2- return $ DConK con_name (args ++ [k2'])-dsKind k@(SigT _ _) = impossible $ "Super-kind signature in kind " ++ (pprint k)-dsKind (VarT name) = return $ DVarK name-dsKind (ConT name) = return $ DConK name []-dsKind (PromotedT name) = impossible $ "Promoted data constructor " ++ show name ++ " in kind."-dsKind (TupleT n) = return $ DConK (tupleTypeName n) []-dsKind (UnboxedTupleT _) = impossible "Unboxed tuple kind."-dsKind ArrowT = impossible "Unsaturated (->) in kind."-dsKind ListT = return $ DConK ''[] []-dsKind (PromotedTupleT _) = impossible "Promoted tuple used as a kind."-dsKind PromotedNilT = impossible "Promoted [] used as a kind."-dsKind PromotedConsT = impossible "Promoted (:) used as a kind."-dsKind StarT = return DStarK-dsKind ConstraintT = return $ DConK ''Constraint []-dsKind (LitT _) = impossible "Literal used in a kind."-#if __GLASGOW_HASKELL__ >= 709-dsKind EqualityT = impossible "(~) used in a kind." #endif -- | Like 'reify', but safer and desugared. Uses local declarations where@@ -966,3 +1153,21 @@ -- | Apply one 'DType' to a list of arguments applyDType :: DType -> [DType] -> DType applyDType = foldl DAppT++-- | Convert a 'DTyVarBndr' into a 'DType'+dTyVarBndrToDType :: DTyVarBndr -> DType+dTyVarBndrToDType (DPlainTV a) = DVarT a+dTyVarBndrToDType (DKindedTV a k) = DVarT a `DSigT` k++-- | Convert a 'Strict' to a 'Bang' in GHCs 7.x. This is just+-- the identity operation in GHC 8.x, which has no 'Strict'.+-- (This is included in GHC 8.x only for good Haddocking.)+#if __GLASGOW_HASKELL__ <= 710+strictToBang :: Strict -> Bang+strictToBang IsStrict = Bang NoSourceUnpackedness SourceStrict+strictToBang NotStrict = Bang NoSourceUnpackedness NoSourceStrictness+strictToBang Unpacked = Bang SourceUnpack SourceStrict+#else+strictToBang :: Bang -> Bang+strictToBang = id+#endif
Language/Haskell/TH/Desugar/Expand.hs view
@@ -110,7 +110,7 @@ ty' <- expand_type ign ty return $ foldl DAppT ty' rest_args - DTyConI (DFamilyD TypeFam _n tvbs _mkind) _+ DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _ | length args >= length tvbs -- this should always be true! , args_ok -> do@@ -128,7 +128,8 @@ return $ foldl DAppT ty' rest_args _ -> return $ foldl DAppT (DConT n) args - DTyConI (DClosedTypeFamilyD _n tvbs _resk eqns) _++ DTyConI (DClosedTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann) eqns) _ | length args >= length tvbs , args_ok -> do@@ -159,7 +160,8 @@ m_info <- dsReify con_name return $ case m_info of Nothing -> False -- we don't know anything. False is safe.- Just (DTyConI (DFamilyD {}) _) -> False+ Just (DTyConI (DOpenTypeFamilyD {}) _) -> False+ Just (DTyConI (DDataFamilyD {}) _) -> False Just (DTyConI (DClosedTypeFamilyD {}) _) -> False _ -> True no_tyvar_tyfam t = gmapQl (liftM2 (&&)) (return True) no_tyvars_tyfams t@@ -258,6 +260,8 @@ dTypeToDPred (DConT n) = return $ DConPr n dTypeToDPred DArrowT = impossible "Arrow used as head of constraint" dTypeToDPred (DLitT _) = impossible "Type literal used as head of constraint"+dTypeToDPred DWildCardT = return DWildCardPr+dTypeToDPred DStarT = impossible "Star used as head of constraint" -- | Expand all type synonyms and type families in the desugared abstract -- syntax tree provided, where type family simplification is on a "best effort"
Language/Haskell/TH/Desugar/Lift.hs view
@@ -23,11 +23,16 @@ import Language.Haskell.TH.Instances () import Language.Haskell.TH.Lift -$(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DKind, ''DPred, ''DTyVarBndr+$(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DPred, ''DTyVarBndr , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DCon , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn , ''NewOrData #if __GLASGOW_HASKELL__ < 707 , ''AnnTarget, ''Role+#endif+ , ''DTypeFamilyHead, ''DFamilyResultSig+#if __GLASGOW_HASKELL__ <= 710+ , ''InjectivityAnn, ''Bang, ''SourceUnpackedness+ , ''SourceStrictness, ''Overlap #endif ])
Language/Haskell/TH/Desugar/Match.hs view
@@ -85,7 +85,7 @@ matchResultToDExp `liftM` simplCase vars eis data EquationInfo = EquationInfo [DPat] MatchResult -- like DClause, but with a hole- + -- analogous to GHC's match (in deSugar/Match.lhs) simplCase :: DsMonad q => [Name] -- the names of the scrutinees@@ -143,7 +143,7 @@ DBangPa p -> tidy1 v (DBangPa p) -- discard ! under ! DWildPa -> return (id, DBangPa pat) -- no change tidy1 _ DWildPa = return (id, DWildPa)- + wrapBind :: Name -> Name -> DExp -> DExp wrapBind new old | new == old = id@@ -209,9 +209,9 @@ data PatGroup = PgAny -- immediate match (wilds, vars, lazies)- | PgCon Name - | PgLit Lit - | PgBang + | PgCon Name+ | PgLit Lit+ | PgBang -- like GHC's groupEquations groupClauses :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]@@ -270,7 +270,7 @@ return $ CaseAlt (pat_con pat1) arg_vars match_result where pat1 = firstPat eqn1- + pat_args (DConPa _ pats) = pats pat_args _ = error "Internal error in th-desugar (pat_args)" @@ -312,7 +312,7 @@ get_cons (DDataInstD _ _ _ _ cons _) = cons get_cons _ = [] - get_con_name (DCon _ _ n _) = n+ get_con_name (DCon _ _ n _ _) = n matchEmpty :: DsMonad q => Name -> q [MatchResult] matchEmpty var = return [mk_seq]
Language/Haskell/TH/Desugar/Reify.hs view
@@ -13,6 +13,9 @@ -- * Reification reifyWithLocals_maybe, reifyWithLocals, reifyWithWarning, reifyInDecs, + -- ** Fixity reification+ qReifyFixity, reifyFixity, reifyFixityWithLocals, reifyFixityInDecs,+ -- * Datatype lookup getDataD, dataConNameToCon, dataConNameToDataName, @@ -30,6 +33,11 @@ import Control.Applicative #endif import qualified Data.Set as S+#if __GLASGOW_HASKELL__ >= 800+import qualified Control.Monad.Fail as Fail+#else+import qualified Control.Monad as Fail+#endif import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax hiding ( lift )@@ -62,13 +70,17 @@ reifyWithWarning name = qRecover (reifyFail name) (qReify name) -- | Print out a warning about separating splices and fail.+#if __GLASGOW_HASKELL__ >= 800+reifyFail :: Fail.MonadFail m => Name -> m a+#else reifyFail :: Monad m => Name -> m a+#endif reifyFail name =- fail $ "Looking up " ++ (show name) ++ " in the list of available " ++- "declarations failed.\nThis lookup fails if the declaration " ++- "referenced was made in the same Template\nHaskell splice as the use " ++- "of the declaration. If this is the case, put\nthe reference to " ++- "the declaration in a new splice."+ Fail.fail $ "Looking up " ++ (show name) ++ " in the list of available " +++ "declarations failed.\nThis lookup fails if the declaration " +++ "referenced was made in the same Template\nHaskell splice as the use " +++ "of the declaration. If this is the case, put\nthe reference to " +++ "the declaration in a new splice." --------------------------------- -- Utilities@@ -85,8 +97,13 @@ TyConI dec -> return dec _ -> badDeclaration case dec of+#if __GLASGOW_HASKELL__ > 710+ DataD _cxt _name tvbs _mk cons _derivings -> return (tvbs, cons)+ NewtypeD _cxt _name tvbs _mk con _derivings -> return (tvbs, [con])+#else DataD _cxt _name tvbs cons _derivings -> return (tvbs, cons) NewtypeD _cxt _name tvbs con _derivings -> return (tvbs, [con])+#endif _ -> badDeclaration where badDeclaration = fail $ "The name (" ++ (show name) ++ ") refers to something " ++@@ -98,7 +115,11 @@ dataConNameToDataName con_name = do info <- reifyWithWarning con_name case info of+#if __GLASGOW_HASKELL__ > 710+ DataConI _name _type parent_name -> return parent_name+#else DataConI _name _type parent_name _fixity -> return parent_name+#endif _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " ++ "a data constructor." @@ -109,16 +130,20 @@ -- 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 ((con_name ==) . get_con_name) cons+ let m_con = 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." where- get_con_name (NormalC name _) = name- get_con_name (RecC name _) = name- get_con_name (InfixC _ name _) = name- get_con_name (ForallC _ _ con) = get_con_name con+ get_con_name (NormalC name _) = [name]+ get_con_name (RecC name _) = [name]+ get_con_name (InfixC _ name _) = [name]+ get_con_name (ForallC _ _ con) = get_con_name con+#if __GLASGOW_HASKELL__ > 710+ get_con_name (GadtC names _ _) = names+ get_con_name (RecGadtC names _ _) = names+#endif -------------------------------------------------- -- DsMonad@@ -138,7 +163,11 @@ -- | A convenient implementation of the 'DsMonad' class. Use by calling -- 'withLocalDeclarations'. newtype DsM q a = DsM (ReaderT [Dec] q a)- deriving (Functor, Applicative, Monad, MonadTrans, Quasi)+ deriving ( Functor, Applicative, Monad, MonadTrans, Quasi+#if __GLASGOW_HASKELL__ >= 800+ , Fail.MonadFail+#endif+ ) instance Quasi q => DsMonad (DsM q) where localDeclarations = DsM ask@@ -170,12 +199,25 @@ reifyInDecs :: Name -> [Dec] -> Maybe Info reifyInDecs n decs = firstMatch (reifyInDec n decs) decs +-- | Look through a list of declarations and possibly return a fixity.+reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity+reifyFixityInDecs n = firstMatch match_fixity+ where+ match_fixity (InfixD fixity n') | n `nameMatches` n' = Just fixity+ match_fixity _ = Nothing++ reifyInDec :: Name -> [Dec] -> Dec -> Maybe Info reifyInDec n decs (FunD n' _) | n `nameMatches` n' = Just $ mkVarI n decs reifyInDec n decs (ValD pat _ _) | any (nameMatches n) (S.elems (extractBoundNamesPat pat)) = Just $ mkVarI n decs+#if __GLASGOW_HASKELL__ > 710+reifyInDec n _ dec@(DataD _ n' _ _ _ _) | n `nameMatches` n' = Just $ TyConI dec+reifyInDec n _ dec@(NewtypeD _ n' _ _ _ _) | n `nameMatches` n' = Just $ TyConI dec+#else reifyInDec n _ dec@(DataD _ n' _ _ _) | n `nameMatches` n' = Just $ TyConI dec reifyInDec n _ dec@(NewtypeD _ n' _ _ _) | n `nameMatches` n' = Just $ TyConI dec+#endif reifyInDec n _ dec@(TySynD n' _ _) | n `nameMatches` n' = Just $ TyConI dec reifyInDec n decs dec@(ClassD _ n' _ _ _) | n `nameMatches` n' = Just $ ClassI (stripClassDec dec) (findInstances n decs)@@ -183,51 +225,99 @@ = Just $ mkVarITy n decs ty reifyInDec n decs (ForeignD (ExportF _ _ n' ty)) | n `nameMatches` n' = Just $ mkVarITy n decs ty+#if __GLASGOW_HASKELL__ > 710+reifyInDec n decs dec@(OpenTypeFamilyD (TypeFamilyHead n' _ _ _)) | n `nameMatches` n'+ = Just $ FamilyI (handleBug8884 dec) (findInstances n decs)+reifyInDec n decs dec@(DataFamilyD n' _ _) | n `nameMatches` n'+ = Just $ FamilyI (handleBug8884 dec) (findInstances n decs)+reifyInDec n _ dec@(ClosedTypeFamilyD (TypeFamilyHead n' _ _ _) _) | n `nameMatches` n'+ = Just $ FamilyI dec []+#else reifyInDec n decs dec@(FamilyD _ n' _ _) | n `nameMatches` n' = Just $ FamilyI (handleBug8884 dec) (findInstances n decs) #if __GLASGOW_HASKELL__ >= 707 reifyInDec n _ dec@(ClosedTypeFamilyD n' _ _ _) | n `nameMatches` n' = Just $ FamilyI dec [] #endif+#endif +#if __GLASGOW_HASKELL__ > 710+reifyInDec n decs (DataD _ ty_name tvbs _mk cons _)+ | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) cons+ = Just info+reifyInDec n decs (NewtypeD _ ty_name tvbs _mk con _)+ | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) [con]+ = Just info+#else reifyInDec n decs (DataD _ ty_name tvbs cons _) | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) cons = Just info reifyInDec n decs (NewtypeD _ ty_name tvbs con _) | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) [con] = Just info+#endif+#if __GLASGOW_HASKELL__ > 710+reifyInDec n _decs (ClassD _ ty_name tvbs _ sub_decs)+ | Just ty <- findType n sub_decs+ = Just $ ClassOpI n (addClassCxt ty_name tvbs ty) ty_name+#else reifyInDec n decs (ClassD _ ty_name tvbs _ sub_decs) | Just ty <- findType n sub_decs = Just $ ClassOpI n (addClassCxt ty_name tvbs ty)- ty_name (findFixity n $ sub_decs ++ decs)+ ty_name (fromMaybe defaultFixity $+ reifyFixityInDecs n $ sub_decs ++ decs)+#endif reifyInDec n decs (ClassD _ _ _ _ sub_decs) | Just info <- firstMatch (reifyInDec n (sub_decs ++ decs)) sub_decs = Just info+#if __GLASGOW_HASKELL__ >= 711+reifyInDec n decs (InstanceD _ _ _ sub_decs)+#else reifyInDec n decs (InstanceD _ _ sub_decs)+#endif | Just info <- firstMatch reify_in_instance sub_decs = Just info where reify_in_instance dec@(DataInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance dec@(NewtypeInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance _ = Nothing+#if __GLASGOW_HASKELL__ > 710+reifyInDec n decs (DataInstD _ ty_name tys _ cons _)+ | Just info <- maybeReifyCon n decs ty_name tys cons+ = Just info+reifyInDec n decs (NewtypeInstD _ ty_name tys _ con _)+ | Just info <- maybeReifyCon n decs ty_name tys [con]+ = Just info+#else reifyInDec n decs (DataInstD _ ty_name tys cons _) | Just info <- maybeReifyCon n decs ty_name tys cons = Just info reifyInDec n decs (NewtypeInstD _ ty_name tys con _) | Just info <- maybeReifyCon n decs ty_name tys [con] = Just info+#endif reifyInDec _ _ _ = Nothing maybeReifyCon :: Name -> [Dec] -> Name -> [Type] -> [Con] -> Maybe Info+#if __GLASGOW_HASKELL__ > 710+maybeReifyCon n _decs ty_name ty_args cons+ | Just con <- findCon n cons+ = Just $ DataConI n (maybeForallT tvbs [] $ con_to_type con) ty_name+#else maybeReifyCon n decs ty_name ty_args cons | Just con <- findCon n cons = Just $ DataConI n (maybeForallT tvbs [] $ con_to_type con) ty_name fixity+#endif | Just ty <- findRecSelector n cons -- we don't try to ferret out naughty record selectors.+#if __GLASGOW_HASKELL__ > 710+ = Just $ VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing+#else = Just $ VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing fixity+#endif where result_ty = foldl AppT (ConT ty_name) ty_args @@ -235,8 +325,13 @@ con_to_type (RecC _ vstys) = mkArrows (map thdOf3 vstys) result_ty con_to_type (InfixC t1 _ t2) = mkArrows (map snd [t1, t2]) result_ty con_to_type (ForallC bndrs cxt c) = ForallT bndrs cxt (con_to_type c)-- fixity = findFixity n decs+#if __GLASGOW_HASKELL__ > 710+ con_to_type (GadtC _ stys rty) = mkArrows (map snd stys) rty+ con_to_type (RecGadtC _ vstys rty) = mkArrows (map thdOf3 vstys) rty+#endif+#if __GLASGOW_HASKELL__ < 711+ fixity = fromMaybe defaultFixity $ reifyFixityInDecs n decs+#endif tvbs = map PlainTV $ S.elems $ freeNamesOfTypes ty_args maybeReifyCon _ _ _ _ _ = Nothing @@ -247,13 +342,12 @@ ++ show n mkVarITy :: Name -> [Dec] -> Type -> Info-mkVarITy n decs ty = VarI n ty Nothing (findFixity n decs)--findFixity :: Name -> [Dec] -> Fixity-findFixity n = fromMaybe defaultFixity . firstMatch match_fixity- where- match_fixity (InfixD fixity n') | n `nameMatches` n' = Just fixity- match_fixity _ = Nothing+#if __GLASGOW_HASKELL__ > 710+mkVarITy n _decs ty = VarI n ty Nothing+#else+mkVarITy n decs ty = VarI n ty Nothing (fromMaybe defaultFixity $+ reifyFixityInDecs n decs)+#endif findType :: Name -> [Dec] -> Maybe Type findType n = firstMatch match_type@@ -264,16 +358,32 @@ findInstances :: Name -> [Dec] -> [Dec] findInstances n = map stripInstanceDec . concatMap match_instance where- match_instance d@(InstanceD _ ty _) | ConT n' <- ty_head ty+#if __GLASGOW_HASKELL__ >= 711+ match_instance d@(InstanceD _ _ ty _)+#else+ match_instance d@(InstanceD _ ty _)+#endif+ | ConT n' <- ty_head ty , n `nameMatches` n' = [d]+#if __GLASGOW_HASKELL__ > 710+ match_instance d@(DataInstD _ n' _ _ _ _) | n `nameMatches` n' = [d]+ match_instance d@(NewtypeInstD _ n' _ _ _ _) | n `nameMatches` n' = [d]+#else match_instance d@(DataInstD _ n' _ _ _) | n `nameMatches` n' = [d] match_instance d@(NewtypeInstD _ n' _ _ _) | n `nameMatches` n' = [d]+#endif #if __GLASGOW_HASKELL__ >= 707 match_instance d@(TySynInstD n' _) | n `nameMatches` n' = [d] #else match_instance d@(TySynInstD n' _ _) | n `nameMatches` n' = [d] #endif- match_instance (InstanceD _ _ decs) = concatMap match_instance decs++#if __GLASGOW_HASKELL__ >= 711+ match_instance (InstanceD _ _ _ decs)+#else+ match_instance (InstanceD _ _ decs)+#endif+ = concatMap match_instance decs match_instance _ = [] ty_head (ForallT _ _ ty) = ty_head ty@@ -287,6 +397,10 @@ where sub_decs' = mapMaybe go sub_decs go (SigD n ty) = Just $ SigD n $ addClassCxt name tvbs ty+#if __GLASGOW_HASKELL__ > 710+ go d@(OpenTypeFamilyD {}) = Just d+ go d@(DataFamilyD {}) = Just d+#endif go _ = Nothing stripClassDec dec = dec @@ -300,8 +414,12 @@ #endif stripInstanceDec :: Dec -> Dec-stripInstanceDec (InstanceD cxt ty _) = InstanceD cxt ty []-stripInstanceDec dec = dec+#if __GLASGOW_HASKELL__ >= 711+stripInstanceDec (InstanceD over cxt ty _) = InstanceD over cxt ty []+#else+stripInstanceDec (InstanceD cxt ty _) = InstanceD cxt ty []+#endif+stripInstanceDec dec = dec mkArrows :: [Type] -> Type -> Type mkArrows [] res_ty = res_ty@@ -320,6 +438,10 @@ match_con (RecC n' _) = n `nameMatches` n' match_con (InfixC _ n' _) = n `nameMatches` n' match_con (ForallC _ _ c) = match_con c+#if __GLASGOW_HASKELL__ > 710+ match_con (GadtC nms _ _) = any (n `nameMatches`) nms+ match_con (RecGadtC nms _ _) = any (n `nameMatches`) nms+#endif findRecSelector :: Name -> [Con] -> Maybe Type findRecSelector n = firstMatch match_con@@ -331,7 +453,6 @@ match_rec_sel (n', _, ty) | n `nameMatches` n' = Just ty match_rec_sel _ = Nothing - handleBug8884 :: Dec -> Dec #if __GLASGOW_HASKELL__ >= 707 handleBug8884 = id@@ -349,3 +470,38 @@ stupid_kind = mkArrows args_kinds result_kind handleBug8884 dec = dec #endif++---------------------------------+-- Reifying fixities+---------------------------------+--+-- This section allows GHC 7.x to call reifyFixity++#if __GLASGOW_HASKELL__ < 711+qReifyFixity :: Quasi m => Name -> m (Maybe Fixity)+qReifyFixity name = do+ info <- qReify name+ return $ case info of+ ClassOpI _ _ _ fixity -> Just fixity+ DataConI _ _ _ fixity -> Just fixity+ VarI _ _ _ fixity -> Just fixity+ _ -> Nothing++{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For+example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then+@reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function+@bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns+'Nothing', so you may assume @bar@ has 'defaultFixity'.+-}+reifyFixity :: Name -> Q (Maybe Fixity)+reifyFixity = qReifyFixity+#endif++-- | Like 'reifyWithLocals_maybe', but for fixities. Note that a return of+-- @Nothing@ might mean that the name is not in scope, or it might mean+-- that the name has no assigned fixity. (Use 'reifyWithLocals_maybe' if+-- you really need to tell the difference.)+reifyFixityWithLocals :: DsMonad q => Name -> q (Maybe Fixity)+reifyFixityWithLocals name = qRecover+ (return . reifyFixityInDecs name =<< localDeclarations)+ (qReifyFixity name)
Language/Haskell/TH/Desugar/Sweeten.hs view
@@ -25,13 +25,15 @@ module Language.Haskell.TH.Desugar.Sweeten ( expToTH, matchToTH, patToTH, decsToTH, decToTH,- letDecToTH, typeToTH, kindToTH,+ letDecToTH, typeToTH, conToTH, foreignToTH, pragmaToTH, ruleBndrToTH, clauseToTH, tvbToTH, cxtToTH, predToTH ) where import Prelude hiding (exp)+import Control.Arrow+ import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Desugar.Core@@ -73,33 +75,83 @@ decToTH :: DDec -> [Dec] decToTH (DLetDec d) = [letDecToTH d] decToTH (DDataD Data cxt n tvbs cons derivings) =- [DataD (cxtToTH cxt) n (map tvbToTH tvbs) (map conToTH cons) derivings]+#if __GLASGOW_HASKELL__ > 710+ [DataD (cxtToTH cxt) n (map tvbToTH tvbs) Nothing (map conToTH cons)+ (cxtToTH derivings)]+#else+ [DataD (cxtToTH cxt) n (map tvbToTH tvbs) (map conToTH cons)+ (map derivingToTH derivings)]+#endif decToTH (DDataD Newtype cxt n tvbs [con] derivings) =- [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (conToTH con) derivings]+#if __GLASGOW_HASKELL__ > 710+ [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) Nothing (conToTH con)+ (cxtToTH derivings)]+#else+ [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (conToTH con)+ (map derivingToTH derivings)]+#endif 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 cxt ty decs) =+#if __GLASGOW_HASKELL__ >= 711+decToTH (DInstanceD over cxt ty decs) =+ [InstanceD over (cxtToTH cxt) (typeToTH ty) (decsToTH decs)]+#else+decToTH (DInstanceD _ cxt ty decs) = [InstanceD (cxtToTH cxt) (typeToTH ty) (decsToTH decs)]+#endif decToTH (DForeignD f) = [ForeignD (foreignToTH f)] decToTH (DPragmaD prag) = maybeToList $ fmap PragmaD (pragmaToTH prag)-decToTH (DFamilyD flav n tvbs m_k) =- [FamilyD flav n (map tvbToTH tvbs) (fmap kindToTH m_k)]+#if __GLASGOW_HASKELL__ > 710+decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs ann)) =+ [OpenTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann)]+#else+decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs _ann)) =+ [FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)]+#endif+decToTH (DDataFamilyD n tvbs) =+#if __GLASGOW_HASKELL__ > 710+ [DataFamilyD n (map tvbToTH tvbs) Nothing]+#else+ [FamilyD DataFam n (map tvbToTH tvbs) Nothing]+#endif decToTH (DDataInstD Data cxt n tys cons derivings) =- [DataInstD (cxtToTH cxt) n (map typeToTH tys) (map conToTH cons) derivings]+#if __GLASGOW_HASKELL__ > 710+ [DataInstD (cxtToTH cxt) n (map typeToTH tys) Nothing (map conToTH cons)+ (cxtToTH derivings)+ ]+#else+ [DataInstD (cxtToTH cxt) n (map typeToTH tys) (map conToTH cons)+ (map derivingToTH derivings)+ ]+#endif decToTH (DDataInstD Newtype cxt n tys [con] derivings) =- [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) (conToTH con) derivings]+#if __GLASGOW_HASKELL__ > 710+ [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) Nothing (conToTH con)+ (cxtToTH derivings)+ ]+#else+ [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) (conToTH con)+ (map derivingToTH derivings)+ ]+#endif #if __GLASGOW_HASKELL__ < 707 decToTH (DTySynInstD n eqn) = [tySynEqnToTHDec n eqn]-decToTH (DClosedTypeFamilyD n tvbs m_k eqns) =- (FamilyD TypeFam n (map tvbToTH tvbs) (fmap kindToTH m_k)) :+decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs _ann) eqns) =+ (FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)) : (map (tySynEqnToTHDec n) eqns) decToTH (DRoleAnnotD {}) = [] #else decToTH (DTySynInstD n eqn) = [TySynInstD n (tySynEqnToTH eqn)]-decToTH (DClosedTypeFamilyD n tvbs m_k eqns) =- [ClosedTypeFamilyD n (map tvbToTH tvbs) (fmap kindToTH m_k)- (map tySynEqnToTH eqns)]+#if __GLASGOW_HASKELL__ > 710+decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs ann) eqns) =+ [ClosedTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann)+ (map tySynEqnToTH eqns)+ ]+#else+decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs _ann) eqns) =+ [ClosedTypeFamilyD n (map tvbToTH tvbs) (frsToTH frs) (map tySynEqnToTH eqns)]+#endif decToTH (DRoleAnnotD n roles) = [RoleAnnotD n roles] #endif #if __GLASGOW_HASKELL__ < 709@@ -114,6 +166,26 @@ #endif decToTH _ = error "Newtype declaration without exactly 1 constructor." +#if __GLASGOW_HASKELL__ > 710+frsToTH :: DFamilyResultSig -> FamilyResultSig+frsToTH DNoSig = NoSig+frsToTH (DKindSig k) = KindSig (typeToTH k)+frsToTH (DTyVarSig tvb) = TyVarSig (tvbToTH tvb)+#else+frsToTH :: DFamilyResultSig -> Maybe Kind+frsToTH DNoSig = Nothing+frsToTH (DKindSig k) = Just (typeToTH k)+frsToTH (DTyVarSig (DPlainTV _)) = Nothing+frsToTH (DTyVarSig (DKindedTV _ k)) = Just (typeToTH k)+#endif++#if __GLASGOW_HASKELL__ <= 710+derivingToTH :: DPred -> Name+derivingToTH (DConPr nm) = nm+derivingToTH p =+ error ("Template Haskell in GHC < 8.0 only allows simple derivings: " ++ show p)+#endif+ letDecToTH :: DLetDec -> Dec letDecToTH (DFunD name clauses) = FunD name (map clauseToTH clauses) letDecToTH (DValD pat exp) = ValD (patToTH pat) (NormalB (expToTH exp)) []@@ -121,12 +193,26 @@ letDecToTH (DInfixD f name) = InfixD f name conToTH :: DCon -> Con-conToTH (DCon [] [] n (DNormalC stys)) =- NormalC n (map (liftSnd typeToTH) stys)-conToTH (DCon [] [] n (DRecC vstys)) =- RecC n (map (liftThdOf3 typeToTH) vstys)-conToTH (DCon tvbs cxt n fields) =- ForallC (map tvbToTH tvbs) (cxtToTH cxt) (conToTH $ DCon [] [] n fields)+#if __GLASGOW_HASKELL__ > 710+conToTH (DCon [] [] n (DNormalC stys) (Just rty)) =+ GadtC [n] (map (second typeToTH) stys) (typeToTH rty)+conToTH (DCon [] [] n (DRecC vstys) (Just rty)) =+ RecGadtC [n] (map (thirdOf3 typeToTH) vstys) (typeToTH rty)+#endif+conToTH (DCon [] [] n (DNormalC stys) _) =+#if __GLASGOW_HASKELL__ > 710+ NormalC n (map (second typeToTH) stys)+#else+ NormalC n (map (bangToStrict *** typeToTH) stys)+#endif+conToTH (DCon [] [] n (DRecC vstys) _) =+#if __GLASGOW_HASKELL__ > 710+ RecC n (map (thirdOf3 typeToTH) vstys)+#else+ RecC n (map (\(v,b,t) -> (v,bangToStrict b,typeToTH t)) vstys)+#endif+conToTH (DCon tvbs cxt n fields rty) =+ ForallC (map tvbToTH tvbs) (cxtToTH cxt) (conToTH $ DCon [] [] n fields rty) foreignToTH :: DForeign -> Foreign foreignToTH (DImportF cc safety str n ty) =@@ -172,15 +258,21 @@ typeToTH :: DType -> Type typeToTH (DForallT tvbs cxt ty) = ForallT (map tvbToTH tvbs) (map predToTH cxt) (typeToTH ty) typeToTH (DAppT t1 t2) = AppT (typeToTH t1) (typeToTH t2)-typeToTH (DSigT ty ki) = SigT (typeToTH ty) (kindToTH ki)+typeToTH (DSigT ty ki) = SigT (typeToTH ty) (typeToTH ki) typeToTH (DVarT n) = VarT n typeToTH (DConT n) = tyconToTH n typeToTH DArrowT = ArrowT typeToTH (DLitT lit) = LitT lit+#if __GLASGOW_HASKELL__ > 710+typeToTH DWildCardT = WildCardT+#else+typeToTH DWildCardT = error "Wildcards supported only in GHC 8.0+"+#endif+typeToTH DStarT = StarT tvbToTH :: DTyVarBndr -> TyVarBndr tvbToTH (DPlainTV n) = PlainTV n-tvbToTH (DKindedTV n k) = KindedTV n (kindToTH k)+tvbToTH (DKindedTV n k) = KindedTV n (typeToTH k) cxtToTH :: DCxt -> Cxt cxtToTH = map predToTH@@ -193,25 +285,25 @@ go acc (DSigPr p _) = go acc p -- this shouldn't happen. go _ (DVarPr _) = error "Template Haskell in GHC <= 7.8 does not support variable constraints."- go acc (DConPr n) + go acc (DConPr n) | nameBase n == "~" , [t1, t2] <- acc = EqualP t1 t2 | otherwise = ClassP n acc+ go _ DWildCardPr+ = error "Wildcards supported only in GHC 8.0+" #else predToTH (DAppPr p t) = AppT (predToTH p) (typeToTH t)-predToTH (DSigPr p k) = SigT (predToTH p) (kindToTH k)+predToTH (DSigPr p k) = SigT (predToTH p) (typeToTH k) predToTH (DVarPr n) = VarT n predToTH (DConPr n) = typeToTH (DConT n)+#if __GLASGOW_HASKELL__ > 710+predToTH DWildCardPr = WildCardT+#else+predToTH DWildCardPr = error "Wildcards supported only in GHC 8.0+" #endif--kindToTH :: DKind -> Kind-kindToTH (DForallK names ki) = ForallT (map PlainTV names) [] (kindToTH ki)-kindToTH (DVarK n) = VarT n-kindToTH (DConK n kis) = foldl AppT (tyconToTH n) (map kindToTH kis)-kindToTH (DArrowK k1 k2) = AppT (AppT ArrowT (kindToTH k1)) (kindToTH k2)-kindToTH DStarK = StarT+#endif tyconToTH :: Name -> Type tyconToTH n@@ -226,3 +318,11 @@ else TupleT deg | Just deg <- unboxedTupleNameDegree_maybe n = UnboxedTupleT deg | otherwise = ConT n++#if __GLASGOW_HASKELL__ <= 710+-- | Convert a 'Bang' to a 'Strict'+bangToStrict :: Bang -> Strict+bangToStrict (Bang SourceUnpack _) = Unpacked+bangToStrict (Bang _ SourceStrict) = IsStrict+bangToStrict (Bang _ _) = NotStrict+#endif
Language/Haskell/TH/Desugar/Util.hs view
@@ -14,8 +14,8 @@ nameOccursIn, allNamesIn, mkTypeName, mkDataName, isDataName, stripVarP_maybe, extractBoundNamesStmt, concatMapM, mapMaybeM, expectJustM,- liftSndM, liftThdOf3M, stripPlainTV_maybe,- liftSnd, liftThdOf3, splitAtList, extractBoundNamesDec,+ stripPlainTV_maybe,+ thirdOf3, splitAtList, extractBoundNamesDec, extractBoundNamesPat, tvbName, tvbToType, nameMatches, freeNamesOfTypes, thdOf3, firstMatch, tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe,@@ -27,7 +27,6 @@ import Language.Haskell.TH hiding ( cxt ) import Language.Haskell.TH.Syntax -import Control.Arrow ( second ) import qualified Data.Set as S import Data.Foldable import Data.Generics hiding ( Fixity )@@ -232,20 +231,11 @@ (x : as, bs) splitAtList (_ : _) [] = ([], []) -liftSnd :: (a -> b) -> (c, a) -> (c, b)-liftSnd = second--liftSndM :: Monad m => (a -> m b) -> (c, a) -> m (c, b)-liftSndM f (c, a) = f a >>= return . (c, )- thdOf3 :: (a,b,c) -> c thdOf3 (_,_,c) = c -liftThdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b)-liftThdOf3 f (c, d, a) = (c, d, f a)--liftThdOf3M :: Monad m => (a -> m b) -> (c, d, a) -> m (c, d, b)-liftThdOf3M f (c, d, a) = f a >>= return . (c, d, )+thirdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b)+thirdOf3 f (c, d, a) = (c, d, f a) -- lift concatMap into a monad -- could this be more efficient?
Test/Dec.hs view
@@ -7,13 +7,18 @@ {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DataKinds, CPP, RankNTypes,- StandaloneDeriving, DefaultSignatures #-}+ StandaloneDeriving, DefaultSignatures,+ ConstraintKinds #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} #endif {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} +#if __GLASGOW_HASKELL__ >= 711+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif+ module Dec where import qualified Splices as S@@ -32,6 +37,8 @@ #if __GLASGOW_HASKELL__ >= 709 $(S.dectest11) #endif+$(S.dectest12)+$(S.dectest13) $(fmap unqualify S.instance_test) @@ -41,4 +48,3 @@ $(fmap unqualify S.imp_inst_test4) $(S.rec_sel_test)-
Test/DsDec.hs view
@@ -7,7 +7,8 @@ {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DataKinds, CPP, RankNTypes,- StandaloneDeriving, DefaultSignatures #-}+ StandaloneDeriving, DefaultSignatures,+ ConstraintKinds #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} #endif@@ -15,6 +16,10 @@ {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns -fno-warn-name-shadowing #-} +#if __GLASGOW_HASKELL__ >= 711+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif+ module DsDec where import qualified Splices as S@@ -53,6 +58,9 @@ $(dsDecSplice S.standalone_deriving_test) #endif +$(dsDecSplice S.dectest12)+$(dsDecSplice S.dectest13)+ $(do decs <- S.rec_sel_test [DDataD nd [] name [DPlainTV tvbName] cons []] <- dsDecs decs let arg_ty = (DConT name) `DAppT` (DVarT tvbName)@@ -62,12 +70,11 @@ reportError $ "Wrong number of record selectors extracted.\n" ++ "Wanted " ++ show S.rec_sel_test_num_sels ++ ", Got " ++ show num_sels- let unrecord c@(DCon _ _ _ (DNormalC {})) = c- unrecord (DCon tvbs cxt con_name (DRecC fields)) =+ let unrecord c@(DCon _ _ _ (DNormalC {}) _) = c+ unrecord (DCon tvbs cxt con_name (DRecC fields) rty) = let (_names, stricts, types) = unzip3 fields fields' = zip stricts types in- DCon tvbs cxt con_name (DNormalC fields')+ DCon tvbs cxt con_name (DNormalC fields') rty plaindata = [DDataD nd [] name [DPlainTV tvbName] (map unrecord cons) []] return (decsToTH plaindata ++ map letDecToTH recsels))-
Test/Run.hs view
@@ -12,6 +12,11 @@ -fno-warn-unused-matches -fno-warn-type-defaults -fno-warn-missing-signatures -fno-warn-unused-do-bind #-} +#if __GLASGOW_HASKELL__ >= 711+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-redundant-constraints #-}+#endif+ module Run where import Prelude hiding ( exp )@@ -101,6 +106,9 @@ , "pred2" ~: $test38_pred2 @=? $(dsSplice test38_pred2) , "eq" ~: $test39_eq @=? $(dsSplice test39_eq) #endif+#if __GLASGOW_HASKELL__ >= 711+ , "wildcard" ~: $test40_wildcards@=? $(dsSplice test40_wildcards)+#endif ] test35a = $test35_expand@@ -159,14 +167,14 @@ test_bug8884 :: Bool test_bug8884 = $(do info <- reify ''Poly- dinfo@(DTyConI (DFamilyD TypeFam _name _tvbs (Just resK))+ dinfo@(DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _name _tvbs (DKindSig resK) _ann)) (Just [DTySynInstD _name2 (DTySynEqn lhs _rhs)])) <- dsInfo info case (resK, lhs) of #if __GLASGOW_HASKELL__ < 709- (DStarK, [DVarT _]) -> [| True |]+ (DStarT, [DVarT _]) -> [| True |] #else- (DStarK, [DSigT (DVarT _) (DVarK _)]) -> [| True |]+ (DStarT, [DSigT (DVarT _) (DVarT _)]) -> [| True |] #endif _ -> do runIO $ do
Test/Splices.hs view
@@ -9,7 +9,7 @@ ScopedTypeVariables, RankNTypes, TypeFamilies, ImpredicativeTypes, DataKinds, PolyKinds, GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, StandaloneDeriving,- DefaultSignatures #-}+ DefaultSignatures, ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-name-shadowing #-} @@ -45,8 +45,14 @@ #else rolesDs <- reifyRoles dsName rolesReg <- reifyRoles regName+#if __GLASGOW_HASKELL__ < 711 eqTHSplice (infoDs, rolesDs) (infoReg, rolesReg)+#else+ fixityDs <- reifyFixity dsName+ fixityReg <- reifyFixity regName+ eqTHSplice (infoDs, rolesDs, fixityDs) (infoReg, rolesReg, fixityReg) #endif+#endif unqualify :: Data a => a -> a unqualify = everywhere (mkT (mkName . nameBase))@@ -79,10 +85,31 @@ then [| True |] else [| False |] +-- Note [Annotating list elements]+--+-- Type annotations on list elements are needed to satisfy GHC 8.0-rc1, otherwise+-- we get errors like:+--+-- Test/Run.hs:63:53: error:+-- • Couldn't match type ‘Maybe Integer’ with ‘forall a. Maybe a’+-- Expected type: [forall a. Maybe a]+-- Actual type: [Maybe Integer]+-- • In the second argument of ‘(:)’, namely+-- ‘(:) (Just 19) ((:) (Nothing :: Maybe Integer) [])’+-- In the second argument of ‘(:)’, namely+-- ‘(:) Nothing ((:) (Just 19) ((:) (Nothing :: Maybe Integer) []))’+-- In the second argument of ‘map’, namely+-- ‘(:)+-- (Just 1)+-- ((:) Nothing ((:) (Just 19) ((:) (Nothing :: Maybe Integer) [])))’+--+-- This is probably a bug in the GHC type checker, but I haven't been able to+-- reduce it yet test1_sections = [| map ((* 3) . (4 +) . (\x -> x * x)) [10, 11, 12] |] test2_lampats = [| (\(Just x) (Left z) -> x + z) (Just 5) (Left 10) |]-test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing, Just 19, Nothing]) |]+-- See Note [Annotating list elements]+test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing :: Maybe Integer, Just 19, Nothing :: Maybe Integer]) |] test4_tuples = [| (\(a, _) (# b, _ #) -> a + b) (1,2) (# 3, 4 #) |] test5_ifs = [| if (5 > 7) then "foo" else if | Nothing <- Just "bar", True -> "blargh" | otherwise -> "bum" |] test6_ifs2 = [| if | Nothing <- Nothing, False -> 3 | Just _ <- Just "foo" -> 5 |]@@ -116,7 +143,8 @@ deriving (Show, Eq) test17_infixp = [| map (\(x :+: y) -> if y then x + 1 else x - 1) [5 :+: True, 10 :+: False] |]-test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined, ()] |]+-- See Note [Annotating list elements]+test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined :: (), ()] |] test19_bangp = [| map (\ !() -> 5) [()] |] test20_asp = [| map (\ a@(b :+: c) -> (if c then b + 1 else b - 1, a)) [5 :+: True, 10 :+: False] |] test21_wildp = [| zipWith (\_ _ -> 10) [1,2,3] ['a','b','c'] |]@@ -124,16 +152,19 @@ -- type signatures in patterns not yet handled by Template Haskell -- test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |] -test24_fun = [| let f (Just x) = x+-- See Note [Annotating list elements]+test24_fun = [| let f :: Maybe (Maybe a) -> Maybe a+ f (Just x) = x f Nothing = Nothing in f (Just (Just 10)) |] +-- See Note [Annotating list elements] test25_fun2 = [| let f (Just x) | x > 0 = x | x < 0 = x + 10 f Nothing = 0 f _ = 18 in- map f [Just (-5), Just 5, Just 10, Nothing, Just 0] |]+ map f [Just (-5), Just 5, Just 10, Nothing :: Maybe Integer, Just 0] |] test26_forall = [| let f :: Num a => a -> a f x = x + 10 in@@ -174,6 +205,12 @@ f = snd in f |] +#if __GLASGOW_HASKELL__ >= 711+test40_wildcards = [| let f :: (Show a, _) => a -> a -> _+ f x y = if x == y then show x else "bad" in+ f True False :: String |]+#endif+ type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a]@@ -246,11 +283,14 @@ dectest8 = [d| type family Dec8 a |] dectest9 = [d| data family Dec9 a (b :: * -> *) :: * -> * |] #if __GLASGOW_HASKELL__ < 707-ds_dectest10 = DClosedTypeFamilyD (mkName "Dec10")- [DPlainTV (mkName "a")]- (Just (DArrowK DStarK DStarK))- [ DTySynEqn [DConT ''Int] (DConT ''Maybe)- , DTySynEqn [DConT ''Bool] (DConT ''[]) ]+ds_dectest10 = DClosedTypeFamilyD+ (DTypeFamilyHead+ (mkName "Dec10")+ [DPlainTV (mkName "a")]+ (DKindSig (DAppT (DAppT DArrowT DStarT) DStarT))+ Nothing)+ [ DTySynEqn [DConT ''Int] (DConT ''Maybe)+ , DTySynEqn [DConT ''Bool] (DConT ''[]) ] dectest10 = [d| type family Dec10 a :: * -> * type instance Dec10 Int = Maybe type instance Dec10 Bool = [] |]@@ -273,6 +313,16 @@ standalone_deriving_test = [d| deriving instance Eq a => Eq (Blarggie a) |] #endif +dectest12 = [d| data Dec12 a where+ MkGInt :: Dec12 Int+ MkGOther :: Dec12 b++ |]++dectest13 = [d| data Dec13 :: (* -> Constraint) -> * where+ MkDec13 :: c a => a -> Dec13 c+ |]+ instance_test = [d| instance (Show a, Show b) => Show (a -> b) where show _ = "function" |] @@ -306,8 +356,13 @@ testRecSelTypes :: Int -> Q Exp testRecSelTypes n = do+#if __GLASGOW_HASKELL__ > 710+ VarI _ ty1 _ <- reify (mkName ("DsDec.recsel" ++ show n))+ VarI _ ty2 _ <- reify (mkName ("Dec.recsel" ++ show n))+#else VarI _ ty1 _ _ <- reify (mkName ("DsDec.recsel" ++ show n)) VarI _ ty2 _ _ <- reify (mkName ("Dec.recsel" ++ show n))+#endif let ty1' = return $ unqualify ty1 ty2' = return $ unqualify ty2 [| let x :: $ty1'@@ -361,7 +416,11 @@ reifyDecsNames :: [Name] reifyDecsNames = map mkName- [ "r1", "R2", "r3", "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11"+ [ "r1"+#if __GLASGOW_HASKELL__ < 711+ , "R2", "r3" -- these fail due to GHC#11797+#endif+ , "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11" , "R12", "R13", "R14", "r15", "r16", "r17", "R18", "R19", "R20" #if __GLASGOW_HASKELL__ >= 707 , "R21"
th-desugar.cabal view
@@ -1,5 +1,5 @@ name: th-desugar-version: 1.5.5+version: 1.6 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell homepage: http://www.cis.upenn.edu/~eir/packages/th-desugar@@ -26,7 +26,7 @@ source-repository this type: git location: https://github.com/goldfirere/th-desugar.git- tag: v1.5.5+ tag: v1.6 library build-depends:@@ -36,7 +36,8 @@ mtl >= 2.1, syb >= 0.4, th-lift >= 0.6.1,- th-orphans >= 0.9.1+ th-orphans >= 0.9.1,+ th-expand-syns >= 0.3.0.6 default-extensions: TemplateHaskell exposed-modules: Language.Haskell.TH.Desugar, Language.Haskell.TH.Desugar.Sweeten,@@ -69,4 +70,5 @@ hspec >= 1.3, th-desugar, th-lift >= 0.6.1,- th-orphans >= 0.9.1+ th-orphans >= 0.9.1,+ th-expand-syns >= 0.3.0.6