th-desugar 1.3.1 → 1.4.0
raw patch · 11 files changed
+953/−53 lines, 11 filesdep ~template-haskell
Dependency ranges changed: template-haskell
Files
- CHANGES.md +22/−0
- Language/Haskell/TH/Desugar.hs +155/−5
- Language/Haskell/TH/Desugar/Core.hs +301/−26
- Language/Haskell/TH/Desugar/Sweeten.hs +86/−0
- Language/Haskell/TH/Desugar/Util.hs +77/−13
- README.md +4/−0
- Test/Dec.hs +40/−0
- Test/DsDec.hs +68/−0
- Test/Run.hs +73/−1
- Test/Splices.hs +122/−4
- th-desugar.cabal +5/−4
CHANGES.md view
@@ -1,3 +1,25 @@+Version 1.4.0+-------------+* All `Dec`s can now be desugared, to the new `DDec` type.++* Sweetening `Dec`s that do not exist in GHC 7.6.3- works on a "best effort" basis:+closed type families are sweetened to open ones, and role annotations are dropped.++* `Info`s can now be desugared. Desugaring takes into account GHC bug #8884, which+meant that reifying poly-kinded type families in GHC 7.6.3- was subtly wrong.++* There is a new function `flattenDValD` which takes a binding like+ `let (a,b) = foo` and breaks it apart into separate assignments for `a` and `b`.++* There is a new `Desugar` class with methods `desugar` and `sweeten`. See+the documentation in `Language.Haskell.TH.Desugar`.++* Variable names that are distinct in desugared code are now guaranteed to+have distinct answers to `nameBase`.++* Added a new function `getRecordSelectors` that extracts types and definitions+of record selectors from a datatype definition.+ Version 1.3.1 ------------- * Update cabal file to include testing files in sdist.
Language/Haskell/TH/Desugar.hs view
@@ -4,6 +4,9 @@ eir@cis.upenn.edu -} +{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies,+ TypeSynonymInstances, FlexibleInstances #-}+ {-| Desugars full Template Haskell syntax into a smaller core syntax for further processing. The desugared types and constructors are prefixed with a D.@@ -12,18 +15,29 @@ module Language.Haskell.TH.Desugar ( -- * Desugared data types DExp(..), DLetDec(..), DPat(..), DType(..), DKind(..), DCxt, DPred(..),- DTyVarBndr(..), DMatch(..), DClause(..),+ DTyVarBndr(..), DMatch(..), DClause(..), DDec(..), NewOrData(..),+ DCon(..), DConFields(..), DStrictType, DVarStrictType, DForeign(..),+ DPragma(..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec,+ Role(..), AnnTarget(..), + -- * The 'Desugar' class+ Desugar(..),+ -- * Main desugaring functions- dsExp, dsPatOverExp, dsPatsOverExp, dsPatX,- dsLetDecs, dsType, dsKind, dsTvb, dsPred,+ dsExp, dsDecs, dsType, dsKind, dsInfo,+ dsPatOverExp, dsPatsOverExp, dsPatX,+ dsLetDecs, dsTvb, dsCxt,+ dsCon, dsForeign, dsPragma, dsRuleBndr, -- ** Secondary desugaring functions- PatM, dsPat, dsLetDec,+ PatM, dsPred, dsPat, dsDec, dsLetDec, dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses, -- * Utility functions- dPatToDExp, removeWilds, reifyWithWarning, getDataD, dataConNameToCon,+ dPatToDExp, removeWilds, reifyWithWarning,+ getDataD, dataConNameToDataName, dataConNameToCon,+ nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors,+ mkTypeName, mkDataName, newUniqueName, mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, -- ** Extracting bound names@@ -32,3 +46,139 @@ import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util+import Language.Haskell.TH.Desugar.Sweeten+import Language.Haskell.TH.Syntax++import qualified Data.Set as S+import Data.Foldable ( foldMap )+import Prelude hiding ( exp )++-- | This class relates a TH type with its th-desugar type and allows+-- conversions back and forth. The functional dependency goes only one+-- way because `Type` and `Kind` are type synonyms, but they desugar+-- to different types.+class Desugar th ds | ds -> th where+ desugar :: Quasi q => th -> q ds+ sweeten :: ds -> th++instance Desugar Exp DExp where+ desugar = dsExp+ sweeten = expToTH++instance Desugar Type DType where+ desugar = dsType+ sweeten = typeToTH++instance Desugar Kind DKind where+ desugar = dsKind+ sweeten = kindToTH++instance Desugar Cxt DCxt where+ desugar = dsCxt+ sweeten = cxtToTH++instance Desugar TyVarBndr DTyVarBndr where+ desugar = dsTvb+ sweeten = tvbToTH++instance Desugar [Dec] [DDec] where+ desugar = dsDecs+ sweeten = decsToTH++instance Desugar Con DCon where+ desugar = dsCon+ sweeten = 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+-- 'DVarPa'. Other declarations are passed through unchanged.+-- Note that the declarations that come out of this function are rather+-- less efficient than those that come in: they have many more pattern+-- matches.+flattenDValD :: Quasi q => DLetDec -> q [DLetDec]+flattenDValD dec@(DValD (DVarPa _) _) = return [dec]+flattenDValD (DValD pat exp) = do+ x <- newUniqueName "x" -- must use newUniqueName here because we might be top-level+ let top_val_d = DValD (DVarPa x) exp+ bound_names = S.elems $ extractBoundNamesDPat pat+ other_val_ds <- mapM (mk_val_d x) bound_names+ return $ top_val_d : other_val_ds+ where+ mk_val_d x name = do+ y <- newUniqueName "y"+ let pat' = wildify name y pat+ match = DMatch pat' (DVarE y)+ cas = DCaseE (DVarE x) [match]+ return $ DValD (DVarPa name) cas++ wildify name y p =+ case p of+ DLitPa lit -> DLitPa lit+ DVarPa n+ | n == name -> DVarPa y+ | otherwise -> DWildPa+ DConPa con ps -> DConPa con (map (wildify name y) ps)+ 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+extractBoundNamesDPat (DLitPa _) = S.empty+extractBoundNamesDPat (DVarPa n) = S.singleton n+extractBoundNamesDPat (DConPa _ pats) = foldMap extractBoundNamesDPat pats+extractBoundNamesDPat (DTildePa pat) = extractBoundNamesDPat pat+extractBoundNamesDPat (DBangPa pat) = extractBoundNamesDPat pat+extractBoundNamesDPat DWildPa = S.empty++fvDType :: DType -> S.Set Name+fvDType = go+ 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 (DVarT n) = S.singleton n+ go (DConT _) = S.empty+ go DArrowT = S.empty+ go (DLitT {}) = 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+ ] ++ where+ 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
@@ -11,7 +11,7 @@ module Language.Haskell.TH.Desugar.Core where -import Prelude hiding (mapM, foldl, foldr, all, elem, exp)+import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and) import Language.Haskell.TH hiding (match, clause, cxt) import Language.Haskell.TH.Syntax hiding (lift)@@ -40,12 +40,6 @@ | DSigE DExp DType deriving (Show, Typeable, Data) --- | Declarations as used in a @let@ statement. Other @Dec@s are not desugared.-data DLetDec = DFunD Name [DClause]- | DValD DPat DExp- | DSigD Name DType- | DInfixD Fixity Name- deriving (Show, Typeable, Data) -- | Corresponds to TH's @Pat@ type. data DPat = DLitPa Lit@@ -99,6 +93,97 @@ data DClause = DClause [DPat] DExp deriving (Show, Typeable, Data) +-- | 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)++-- | Is it a @newtype@ or a @data@ type?+data NewOrData = Newtype+ | Data+ deriving (Eq, Show, Typeable, Data)++-- | Corresponds to TH's @Dec@ type.+data DDec = DLetDec DLetDec+ | DDataD NewOrData DCxt Name [DTyVarBndr] [DCon] [Name]+ | DTySynD Name [DTyVarBndr] DType+ | DClassD DCxt Name [DTyVarBndr] [FunDep] [DDec]+ | DInstanceD DCxt DType [DDec]+ | DForeignD DForeign+ | DPragmaD DPragma+ | DFamilyD FamFlavour Name [DTyVarBndr] (Maybe DKind)+ | DDataInstD NewOrData DCxt Name [DType] [DCon] [Name]+ | DTySynInstD Name DTySynEqn+ | DClosedTypeFamilyD Name [DTyVarBndr] (Maybe DKind) [DTySynEqn]+ | DRoleAnnotD Name [Role]+ deriving (Show, Typeable, Data)++-- | Corresponds to TH's @Con@ type.+data DCon = DCon [DTyVarBndr] DCxt Name DConFields+ deriving (Show, Typeable, Data)++-- | 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)++-- | Corresponds to TH's @StrictType@ type.+type DStrictType = (Strict, DType)++-- | Corresponds to TH's @VarStrictType@ type.+type DVarStrictType = (Name, Strict, DType)++-- | Corresponds to TH's @Foreign@ type.+data DForeign = DImportF Callconv Safety String Name DType+ | DExportF Callconv String Name DType+ deriving (Show, Typeable, Data)++-- | Corresponds to TH's @Pragma@ type.+data DPragma = DInlineP Name Inline RuleMatch Phases+ | DSpecialiseP Name DType (Maybe Inline) Phases+ | DSpecialiseInstP DType+ | DRuleP String [DRuleBndr] DExp DExp Phases+ | DAnnP AnnTarget DExp+ deriving (Show, Typeable, Data)++-- | Corresponds to TH's @RuleBndr@ type.+data DRuleBndr = DRuleVar Name+ | DTypedRuleVar Name DType+ deriving (Show, Typeable, Data)++-- | Corresponds to TH's @TySynEqn@ type (to store type family equations).+data DTySynEqn = DTySynEqn [DType] DType+ deriving (Show, Typeable, Data)++#if __GLASGOW_HASKELL__ < 707+-- | Same as @Role@ from TH; defined here for GHC 7.6.3 compatibility.+data Role = Nominal | Representational | Phantom+ deriving (Show, Typeable, Data)++-- | Same as @AnnTarget@ from TH; defined here for GHC 7.6.3 compatibility.+data AnnTarget = ModuleAnnotation+ | TypeAnnotation Name+ | ValueAnnotation Name+ deriving (Show, Typeable, Data)+#endif++-- | Corresponds to TH's @Info@ type.+data DInfo = DTyConI DDec (Maybe [DInstanceDec])+ | DVarI Name DType (Maybe Name) Fixity+ -- ^ The @Maybe Name@ stores the name of the enclosing definition+ -- (datatype, for a data constructor; class, for a method),+ -- if any+ | DTyVarI Name DKind+ | DPrimTyConI Name Int Bool+ -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon+ -- is unlifted.+ deriving (Show, Typeable, Data)++type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration+ -- | Desugar an expression dsExp :: Quasi q => Exp -> q DExp dsExp (VarE n) = return $ DVarE n@@ -108,7 +193,7 @@ dsExp (InfixE Nothing op Nothing) = dsExp op dsExp (InfixE (Just lhs) op Nothing) = DAppE <$> (dsExp op) <*> (dsExp lhs) dsExp (InfixE Nothing op (Just rhs)) = do- lhsName <- qNewName "lhs"+ lhsName <- newUniqueName "lhs" op' <- dsExp op rhs' <- dsExp rhs return $ DLamE [lhsName] (foldl DAppE op' [DVarE lhsName, rhs'])@@ -119,7 +204,7 @@ dsExp (ParensE exp) = dsExp exp dsExp (LamE pats exp) = dsLam pats =<< dsExp exp dsExp (LamCaseE matches) = do- x <- qNewName "x"+ x <- newUniqueName "x" matches' <- dsMatches x matches return $ DLamE [x] (DCaseE (DVarE x) matches') dsExp (TupE exps) = do@@ -127,17 +212,15 @@ return $ foldl DAppE (DConE $ tupleDataName (length exps)) exps' dsExp (UnboxedTupE exps) = foldl DAppE (DConE $ unboxedTupleDataName (length exps)) <$> mapM dsExp exps-dsExp (CondE e1 e2 e3) = do- e1' <- dsExp e1- e2' <- dsExp e2- e3' <- dsExp e3- return $ DCaseE e1' [DMatch (DConPa 'True []) e2', DMatch (DConPa 'False []) e3']+dsExp (CondE e1 e2 e3) =+ dsExp (CaseE e1 [ Match (ConP 'True []) (NormalB e2) []+ , Match (ConP 'False []) (NormalB e3) [] ]) dsExp (MultiIfE guarded_exps) =- let failure = DAppE (DVarE 'error) (DLitE (StringL "None-exhaustive guards in multi-way if")) in+ let failure = DAppE (DVarE 'error) (DLitE (StringL "Non-exhaustive guards in multi-way if")) in dsGuards guarded_exps failure dsExp (LetE decs exp) = DLetE <$> dsLetDecs decs <*> dsExp exp dsExp (CaseE exp matches) = do- scrutinee <- qNewName "scrutinee"+ scrutinee <- newUniqueName "scrutinee" exp' <- dsExp exp matches' <- dsMatches scrutinee matches return $ DLetE [DValD (DVarPa scrutinee) exp'] $@@ -201,7 +284,7 @@ con_to_dmatch :: Quasi q => Con -> q DMatch con_to_dmatch (RecC con_name args) = do let con_field_names = map fst_of_3 args- field_var_names <- mapM (qNewName . nameBase) con_field_names+ field_var_names <- mapM (newUniqueName . nameBase) con_field_names DMatch (DConPa con_name (map DVarPa field_var_names)) <$> (foldl DAppE (DConE con_name) <$> (reorderFields args field_exps (map DVarE field_var_names)))@@ -218,7 +301,7 @@ | Just names <- mapM stripVarP_maybe pats = return $ DLamE names exp | otherwise- = do arg_names <- replicateM (length pats) (qNewName "arg")+ = do arg_names <- replicateM (length pats) (newUniqueName "arg") let scrutinee = mkTupleDExp (map DVarE arg_names) (pats', exp') <- dsPatsOverExp pats exp let match = DMatch (mkTupleDPat pats') exp'@@ -238,7 +321,10 @@ let failure = DCaseE (DVarE scr) rest' -- this might be an empty case. exp' <- dsBody body where_decs failure (pat', exp'') <- dsPatOverExp pat exp'- return (DMatch pat' exp'' : rest')+ uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6+ if uni_pattern+ then return [DMatch pat' exp'']+ else return (DMatch pat' exp'' : rest') -- | Desugar a @Body@ dsBody :: Quasi q@@ -290,6 +376,16 @@ decs' <- dsLetDecs decs success' <- dsGuardStmts rest success failure return $ DLetE decs' success'+ -- special-case a final pattern containing "otherwise" or "True"+ -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr+dsGuardStmts [NoBindS exp] success _failure+ | VarE name <- exp+ , name == 'otherwise+ = return success++ | ConE name <- exp+ , name == 'True+ = return success dsGuardStmts (NoBindS exp : rest) success failure = do exp' <- dsExp exp success' <- dsGuardStmts rest success failure@@ -438,8 +534,120 @@ removeWilds (DConPa con_name pats) = DConPa con_name <$> mapM removeWilds pats removeWilds (DTildePa pat) = DTildePa <$> removeWilds pat removeWilds (DBangPa pat) = DBangPa <$> removeWilds pat-removeWilds DWildPa = DVarPa <$> qNewName "wild"+removeWilds DWildPa = DVarPa <$> newUniqueName "wild" +-- | Desugar @Info@+dsInfo :: Quasi q => Info -> q DInfo+dsInfo (ClassI dec instances) = do+ [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+dsInfo (TyConI dec) = do+ [ddec] <- dsDec dec+ return $ DTyConI ddec Nothing+dsInfo (FamilyI dec instances) = do+ [ddec] <- dsDec dec+ dinstances <- dsDecs instances+ (ddec', num_args) <- fixBug8884ForFamilies ddec+ let dinstances' = map (fixBug8884ForInstances num_args) dinstances+ 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+dsInfo (VarI name _ (Just _) _) =+ impossible $ "Declaration supplied with variable: " ++ show name+dsInfo (TyVarI name ty) = DTyVarI name <$> dsKind ty++fixBug8884ForFamilies :: Quasi q => DDec -> q (DDec, Int)+#if __GLASGOW_HASKELL__ < 708+fixBug8884ForFamilies (DFamilyD flav name tvbs m_kind) = 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+ 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)+fixBug8884ForFamilies dec =+ impossible $ "Reifying yielded a FamilyI with a non-family Dec: " ++ show dec++remove_arrows :: Quasi q => Int -> DKind -> q DKind+remove_arrows 0 k = return k+remove_arrows n (DArrowK _ k) = remove_arrows (n-1) k+remove_arrows _ _ =+ impossible "Internal error: Fix for bug 8884 ran out of arrows."+ +#else+fixBug8884ForFamilies dec = return (dec, 0) -- return value ignored+#endif++fixBug8884ForInstances :: Int -> DDec -> DDec+fixBug8884ForInstances num_args (DTySynInstD name eqn) =+ DTySynInstD name (fixBug8884ForEqn num_args eqn)+fixBug8884ForInstances _ dec = dec++fixBug8884ForEqn :: Int -> DTySynEqn -> DTySynEqn+#if __GLASGOW_HASKELL__ < 708+fixBug8884ForEqn num_args (DTySynEqn lhs rhs) =+ let lhs' = drop (length lhs - num_args) lhs in+ DTySynEqn lhs' rhs+#else+fixBug8884ForEqn _ = id+#endif++-- | Desugar arbitrary @Dec@s+dsDecs :: Quasi q => [Dec] -> q [DDec]+dsDecs = concatMapM dsDec++-- | Desugar a single @Dec@, perhaps producing multiple 'DDec's+dsDec :: Quasi q => Dec -> q [DDec]+dsDec d@(FunD {}) = (fmap . map) DLetDec $ dsLetDec d+dsDec d@(ValD {}) = (fmap . map) DLetDec $ dsLetDec d+dsDec (DataD cxt n tvbs cons derivings) =+ (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n+ <*> mapM dsTvb tvbs <*> mapM dsCon cons+ <*> pure derivings)+dsDec (NewtypeD cxt n tvbs con derivings) =+ (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n+ <*> mapM dsTvb tvbs <*> ((:[]) <$> dsCon con)+ <*> pure derivings)+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)+dsDec (InstanceD cxt ty decs) =+ (:[]) <$> (DInstanceD <$> dsCxt cxt <*> dsType ty <*> dsDecs decs)+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) =+ (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n <*> mapM dsType tys+ <*> mapM dsCon cons <*> pure derivings)+dsDec (NewtypeInstD cxt n tys con derivings) =+ (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n <*> mapM dsType tys+ <*> ((:[]) <$> dsCon con) <*> pure derivings)+#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)+dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles]+#endif+ -- | Desugar @Dec@s that can appear in a let expression dsLetDecs :: Quasi q => [Dec] -> q [DLetDec] dsLetDecs = concatMapM dsLetDec@@ -463,6 +671,51 @@ dsLetDec (InfixD fixity name) = return [DInfixD fixity name] dsLetDec _dec = impossible "Illegal declaration in let expression." +-- | Desugar a single @Con@.+dsCon :: Quasi 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 (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++-- | Desugar a @Foreign@.+dsForeign :: Quasi q => Foreign -> q DForeign+dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty+dsForeign (ExportF cc str n ty) = DExportF cc str n <$> dsType ty++-- | Desugar a @Pragma@.+dsPragma :: Quasi q => Pragma -> q DPragma+dsPragma (InlineP n inl rm phases) = return $ DInlineP n inl rm phases+dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty+ <*> pure m_inl+ <*> pure phases+dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty+dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str <$> mapM dsRuleBndr rbs+ <*> dsExp lhs+ <*> dsExp rhs+ <*> pure phases+#if __GLASGOW_HASKELL__ >= 707+dsPragma (AnnP target exp) = DAnnP target <$> dsExp exp+#endif++-- | Desugar a @RuleBndr@.+dsRuleBndr :: Quasi q => RuleBndr -> q DRuleBndr+dsRuleBndr (RuleVar n) = return $ DRuleVar n+dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty++#if __GLASGOW_HASKELL__ >= 707+-- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)+dsTySynEqn :: Quasi q => TySynEqn -> q DTySynEqn+dsTySynEqn (TySynEqn lhs rhs) = DTySynEqn <$> mapM dsType lhs <*> dsType rhs+#endif+ -- | Desugar clauses to a function definition dsClauses :: Quasi q => Name -- ^ Name of the function@@ -478,7 +731,7 @@ (pats', exp'') <- dsPatsOverExp pats exp_with_wheres return $ DClause pats' exp'' : rest' dsClauses n clauses@(Clause outer_pats _ _ : _) = do- arg_names <- replicateM (length outer_pats) (qNewName "arg")+ arg_names <- replicateM (length outer_pats) (newUniqueName "arg") let scrutinee = mkTupleDExp (map DVarE arg_names) clause <- DClause (map DVarPa arg_names) <$> (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses)@@ -486,15 +739,19 @@ where clause_to_dmatch :: Quasi q => DExp -> Clause -> [DMatch] -> q [DMatch] clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do+ let failure_exp = maybeDCaseE ("Non-exhaustive patterns in " ++ (show n))+ scrutinee failure_matches exp <- dsBody body where_decs failure_exp (pats', exp') <- dsPatsOverExp pats exp- return (DMatch (mkTupleDPat pats') exp' : failure_matches)- where- failure_exp = maybeDCaseE ("Non-exhaustive patterns in " ++ (show n))- scrutinee failure_matches+ uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats'+ let match = DMatch (mkTupleDPat pats') exp'+ if uni_pats+ then return [match]+ else return (match : failure_matches)+ -- | Desugar a type dsType :: Quasi q => Type -> q DType-dsType (ForallT tvbs preds ty) = DForallT <$> mapM dsTvb tvbs <*> concatMapM dsPred preds <*> dsType ty+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 (VarT name) = return $ DVarT name@@ -523,6 +780,10 @@ dsTvb (PlainTV n) = return $ DPlainTV n dsTvb (KindedTV n k) = DKindedTV n <$> dsKind k +-- | Desugar a @Cxt@+dsCxt :: Quasi q => Cxt -> q DCxt+dsCxt = concatMapM dsPred+ -- | Desugar a @Pred@, flattening any internal tuples dsPred :: Quasi q => Pred -> q DCxt #if __GLASGOW_HASKELL__ < 709@@ -646,3 +907,17 @@ mkTuplePat :: [Pat] -> Pat mkTuplePat [pat] = pat mkTuplePat pats = ConP (tupleDataName (length pats)) pats++-- | Is this pattern guaranteed to match?+isUniversalPattern :: Quasi q => DPat -> q Bool+isUniversalPattern (DLitPa {}) = return False+isUniversalPattern (DVarPa {}) = return True+isUniversalPattern (DConPa con_name pats) = do+ data_name <- dataConNameToDataName con_name+ (_tvbs, cons) <- getDataD "Internal error." data_name+ if length cons == 1+ then fmap and $ mapM isUniversalPattern pats+ else return False+isUniversalPattern (DTildePa {}) = return True+isUniversalPattern (DBangPa pat) = isUniversalPattern pat+isUniversalPattern DWildPa = return True
Language/Haskell/TH/Desugar/Sweeten.hs view
@@ -17,7 +17,10 @@ import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Desugar.Core+import Language.Haskell.TH.Desugar.Util +import Data.Maybe ( maybeToList )+ expToTH :: DExp -> Exp expToTH (DVarE n) = VarE n expToTH (DConE n) = ConE n@@ -39,12 +42,92 @@ patToTH (DBangPa pat) = BangP (patToTH pat) patToTH DWildPa = WildP +decsToTH :: [DDec] -> [Dec]+decsToTH = concatMap decToTH++-- | This returns a list of @Dec@s because GHC 7.6.3 does not have+-- a one-to-one mapping between 'DDec' and @Dec@.+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]+decToTH (DDataD Newtype cxt n tvbs [con] derivings) =+ [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (conToTH con) derivings]+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) =+ [InstanceD (cxtToTH cxt) (typeToTH ty) (decsToTH decs)]+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)]+decToTH (DDataInstD Data cxt n tys cons derivings) =+ [DataInstD (cxtToTH cxt) n (map typeToTH tys) (map conToTH cons) derivings]+decToTH (DDataInstD Newtype cxt n tys [con] derivings) =+ [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) (conToTH con) derivings]+#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)) :+ (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)]+decToTH (DRoleAnnotD n roles) = [RoleAnnotD n roles]+#endif+decToTH _ = error "Newtype declaration without exactly 1 constructor."+ letDecToTH :: DLetDec -> Dec letDecToTH (DFunD name clauses) = FunD name (map clauseToTH clauses) letDecToTH (DValD pat exp) = ValD (patToTH pat) (NormalB (expToTH exp)) [] letDecToTH (DSigD name ty) = SigD name (typeToTH ty) letDecToTH (DInfixD f name) = InfixD f name +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)++foreignToTH :: DForeign -> Foreign+foreignToTH (DImportF cc safety str n ty) =+ ImportF cc safety str n (typeToTH ty)+foreignToTH (DExportF cc str n ty) = ExportF cc str n (typeToTH ty)++pragmaToTH :: DPragma -> Maybe Pragma+pragmaToTH (DInlineP n inl rm phases) = Just $ InlineP n inl rm phases+pragmaToTH (DSpecialiseP n ty m_inl phases) =+ Just $ SpecialiseP n (typeToTH ty) m_inl phases+pragmaToTH (DSpecialiseInstP ty) = Just $ SpecialiseInstP (typeToTH ty)+pragmaToTH (DRuleP str rbs lhs rhs phases) =+ Just $ RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases+#if __GLASGOW_HASKELL__ < 707+pragmaToTH (DAnnP {}) = Nothing+#else+pragmaToTH (DAnnP target exp) = Just $ AnnP target (expToTH exp)+#endif++ruleBndrToTH :: DRuleBndr -> RuleBndr+ruleBndrToTH (DRuleVar n) = RuleVar n+ruleBndrToTH (DTypedRuleVar n ty) = TypedRuleVar n (typeToTH ty)++#if __GLASGOW_HASKELL__ < 707+-- | GHC 7.6.3 doesn't have TySynEqn, so we sweeten to a Dec in GHC 7.6.3;+-- GHC 7.8+ does not use this function+tySynEqnToTHDec :: Name -> DTySynEqn -> Dec+tySynEqnToTHDec n (DTySynEqn lhs rhs) =+ TySynInstD n (map typeToTH lhs) (typeToTH rhs)+#else+tySynEqnToTH :: DTySynEqn -> TySynEqn+tySynEqnToTH (DTySynEqn lhs rhs) = TySynEqn (map typeToTH lhs) (typeToTH rhs)+#endif+ clauseToTH :: DClause -> Clause clauseToTH (DClause pats exp) = Clause (map patToTH pats) (NormalB (expToTH exp)) [] @@ -60,6 +143,9 @@ tvbToTH :: DTyVarBndr -> TyVarBndr tvbToTH (DPlainTV n) = PlainTV n tvbToTH (DKindedTV n k) = KindedTV n (kindToTH k)++cxtToTH :: DCxt -> Cxt+cxtToTH = map predToTH predToTH :: DPred -> Pred #if __GLASGOW_HASKELL__ < 709
Language/Haskell/TH/Desugar/Util.hs view
@@ -6,16 +6,20 @@ Utility functions for th-desugar package. -} -{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, TupleSections #-} module Language.Haskell.TH.Desugar.Util where +import Prelude hiding (mapM)+ import Language.Haskell.TH-import Language.Haskell.TH.Syntax ( Quasi(..) )+import Language.Haskell.TH.Syntax ( Quasi(..), mkNameG_tc, mkNameG_d ) import qualified Data.Set as S import Data.Foldable-import Control.Applicative+import Data.Generics+import Data.Traversable+import Data.Monoid -- | Reify a declaration, warning the user about splices if the reify fails. -- The warning says that reification can fail if you try to reify a type in@@ -29,9 +33,16 @@ "the declaration in a new splice.") (qReify name) +-- | Like newName, but even more unique (unique across different splices),+-- and with unique @nameBase@s.+newUniqueName :: Quasi q => String -> q Name+newUniqueName str = do+ n <- qNewName str+ qNewName $ show n+ -- | Report that a certain TH construct is impossible impossible :: Quasi q => String -> q a-impossible err = fail (err ++ "\nThis should not happen in Haskell.\nPlease email eir@cis.upenn.edu with your code if you see this.")+impossible err = fail (err ++ "\n This should not happen in Haskell.\n Please email eir@cis.upenn.edu with your code if you see this.") -- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type getDataD :: Quasi q@@ -51,15 +62,22 @@ fail $ "The name (" ++ (show name) ++ ") refers to something " ++ "other than a datatype. " ++ err +-- | From the name of a data constructor, retrive the datatype definition it+-- is a part of.+dataConNameToDataName :: Quasi q => Name -> q Name+dataConNameToDataName con_name = do+ info <- reifyWithWarning con_name+ case info of+ DataConI _name _type parent_name _fixity -> return parent_name+ _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " +++ "a data constructor."+ -- | From the name of a data constructor, retrieve its definition as a @Con@ dataConNameToCon :: Quasi q => Name -> q Con dataConNameToCon con_name = do -- we need to get the field ordering from the constructor. We must reify -- the constructor to get the tycon, and then reify the tycon to get the `Con`s- info <- reifyWithWarning con_name- type_name <- case info of- DataConI _name _type parent_name _fixity -> return parent_name- _ -> impossible "Non-data-con used to construct a record."+ 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 case m_con of@@ -72,6 +90,36 @@ get_con_name (InfixC _ name _) = name get_con_name (ForallC _ _ con) = get_con_name con +-- | Check if a name occurs anywhere within a TH tree.+nameOccursIn :: Data a => Name -> a -> Bool+nameOccursIn n = everything (||) $ mkQ False (== n)++-- | Extract all Names mentioned in a TH tree.+allNamesIn :: Data a => a -> [Name]+allNamesIn = everything (++) $ mkQ [] (:[])+ +-- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume+-- it is declared in the current module.+mkTypeName :: Quasi q => String -> q Name+mkTypeName str = do+ m_name <- qLookupName True str+ case m_name of+ Just name -> return name+ Nothing -> do+ Loc { loc_package = pkg, loc_module = modu } <- qLocation+ return $ mkNameG_tc pkg modu str++-- | Like TH's @lookupDataName@, but if this name is not bound, then we assume+-- it is declared in the current module.+mkDataName :: Quasi q => String -> q Name+mkDataName str = do+ m_name <- qLookupName False str+ case m_name of+ Just name -> return name+ Nothing -> do+ Loc { loc_package = pkg, loc_module = modu } <- qLocation+ return $ mkNameG_d pkg modu str+ -- | Extracts the name out of a variable pattern, or returns @Nothing@ stripVarP_maybe :: Pat -> Maybe Name stripVarP_maybe (VarP name) = Just name@@ -117,11 +165,6 @@ extractBoundNamesPat (SigP pat _) = extractBoundNamesPat pat extractBoundNamesPat (ViewP _ pat) = extractBoundNamesPat pat --- | Concatenate the result of a @mapM@-concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b]-concatMapM _ [] = pure []-concatMapM f (a : as) = (++) <$> f a <*> concatMapM f as- -- like GHC's splitAtList :: [a] -> [b] -> ([b], [b]) splitAtList [] x = ([], x)@@ -157,3 +200,24 @@ -- | Extract the degree of a tuple name, if the argument is a tuple name tupleNameDegree_maybe :: Name -> Maybe Int tupleNameDegree_maybe = tupleDegree_maybe . nameBase++liftSnd :: (a -> b) -> (c, a) -> (c, b)+liftSnd f (c, a) = (c, f a)++liftSndM :: Monad m => (a -> m b) -> (c, a) -> m (c, b)+liftSndM f (c, a) = f a >>= return . (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, )++-- lift concatMap into a monad+-- could this be more efficient?+-- | Concatenate the result of a @mapM@+concatMapM :: (Monad monad, Monoid monoid, Traversable t)+ => (a -> monad monoid) -> t a -> monad monoid+concatMapM fn list = do+ bss <- mapM fn list+ return $ fold bss
README.md view
@@ -13,6 +13,10 @@ is a hand-coded TH syntax tree, the results may be unpredictable. In particular, it is likely that promoted datatypes will not work as expected. +One explicit goal of this package is to reduce the burden of supporting multiple+GHC / TH versions. Thus, the desugared language is the same across all GHC versions,+and any inconsistencies are handled internally.+ The package was designed for use with the `singletons` package, so some design decisions are based on that use case, when more than one design choice was possible.
+ Test/Dec.hs view
@@ -0,0 +1,40 @@+{- Tests for the th-desugar package++(c) Richard Eisenberg 2013+eir@cis.upenn.edu+-}++{-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,+ MultiParamTypeClasses, FunctionalDependencies,+ FlexibleInstances, DataKinds, CPP, RankNTypes #-}+#if __GLASGOW_HASKELL__ >= 707+{-# LANGUAGE RoleAnnotations #-}+#endif++{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}++module Test.Dec where++import qualified Test.Splices as S+import Test.Splices ( unqualify )++$(S.dectest1)+$(S.dectest2)+$(S.dectest3)+$(S.dectest4)+$(S.dectest5)+$(S.dectest6)+$(S.dectest7)+$(S.dectest8)+$(S.dectest9)+$(S.dectest10)++$(fmap unqualify S.instance_test)++$(fmap unqualify S.imp_inst_test1)+$(fmap unqualify S.imp_inst_test2)+$(fmap unqualify S.imp_inst_test3)+$(fmap unqualify S.imp_inst_test4)++$(S.rec_sel_test)+
+ Test/DsDec.hs view
@@ -0,0 +1,68 @@+{- Tests for the th-desugar package++(c) Richard Eisenberg 2013+eir@cis.upenn.edu+-}++{-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,+ MultiParamTypeClasses, FunctionalDependencies,+ FlexibleInstances, DataKinds, CPP, RankNTypes #-}+#if __GLASGOW_HASKELL__ >= 707+{-# LANGUAGE RoleAnnotations #-}+#endif++{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns+ -fno-warn-name-shadowing #-}++module Test.DsDec where++import qualified Test.Splices as S+import Test.Splices ( dsDecSplice, unqualify )++import Language.Haskell.TH ( reportError )+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Desugar.Sweeten++import Control.Monad++$(dsDecSplice S.dectest1)+$(dsDecSplice S.dectest2)+$(dsDecSplice S.dectest3)+$(dsDecSplice S.dectest4)+$(dsDecSplice S.dectest5)+$(dsDecSplice S.dectest6)+$(dsDecSplice S.dectest7)+$(dsDecSplice S.dectest8)+$(dsDecSplice S.dectest9)++$(dsDecSplice (fmap unqualify S.instance_test))++$(dsDecSplice (fmap unqualify S.imp_inst_test1))+$(dsDecSplice (fmap unqualify S.imp_inst_test2))+$(dsDecSplice (fmap unqualify S.imp_inst_test3))+$(dsDecSplice (fmap unqualify S.imp_inst_test4))++#if __GLASGOW_HASKELL__ < 707+$(return $ decsToTH [S.ds_dectest10])+#else+$(dsDecSplice S.dectest10)+#endif++$(do decs <- S.rec_sel_test+ [DDataD nd [] name [DPlainTV tvbName] cons []] <- dsDecs decs+ let arg_ty = (DConT name) `DAppT` (DVarT tvbName)+ recsels <- fmap concat $ mapM (getRecordSelectors arg_ty) cons+ let num_sels = length recsels `div` 2 -- ignore type sigs+ when (num_sels /= S.rec_sel_test_num_sels) $+ 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 (_names, stricts, types) = unzip3 fields+ fields' = zip stricts types+ in+ DCon tvbs cxt con_name (DNormalC fields')+ plaindata = [DDataD nd [] name [DPlainTV tvbName] (map unrecord cons) []]+ return (decsToTH plaindata ++ map letDecToTH recsels))+
Test/Run.hs view
@@ -6,22 +6,34 @@ {-# LANGUAGE TemplateHaskell, UnboxedTuples, ParallelListComp, CPP, RankNTypes, ImpredicativeTypes, TypeFamilies,- DataKinds, ConstraintKinds #-}+ DataKinds, ConstraintKinds, PolyKinds #-} {-# 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 #-} module Test.Run where +import Prelude hiding ( exp )+ import Test.HUnit import Test.Hspec import Test.Hspec.HUnit import Test.Splices+import qualified Test.DsDec+import qualified Test.Dec+import Test.Dec ( RecordSel ) import Language.Haskell.TH.Desugar import Language.Haskell.TH.Desugar.Expand import Language.Haskell.TH.Desugar.Sweeten+import Language.Haskell.TH +import Control.Monad++#if __GLASGOW_HASKELL__ >= 707+import Data.Proxy+#endif+ tests :: Test tests = test [ "sections" ~: $test1_sections @=? $(dsSplice test1_sections) , "lampats" ~: $test2_lampats @=? $(dsSplice test2_lampats)@@ -80,10 +92,70 @@ test_expand = and [ hasSameType test35a test35b , hasSameType test36a test36b] +test_dec :: [Bool]+test_dec = $(do bools <- mapM testDecSplice dec_test_nums+ return $ ListE bools)++$( do fuzzType <- mkTypeName "Fuzz"+ fuzzData <- mkDataName "Fuzz"+ let tySynDecs = TySynD (mkName "FuzzSyn") [] (ConT fuzzType)+ dataSynDecs = TySynD (mkName "FuzzDataSyn") [] (ConT fuzzData)+ fuzzDecs <- [d| data Fuzz = Fuzz |]+ return $ tySynDecs : dataSynDecs : fuzzDecs )++test_mkName :: Bool+test_mkName = and [ hasSameType (Proxy :: Proxy FuzzSyn) (Proxy :: Proxy Fuzz)+ , hasSameType (Proxy :: Proxy FuzzDataSyn) (Proxy :: Proxy 'Fuzz) ]++test_bug8884 :: Bool+test_bug8884 = $(do info <- reify ''Poly+ dinfo@(DTyConI (DFamilyD TypeFam _name _tvbs (Just resK))+ (Just [DTySynInstD _name2 (DTySynEqn lhs _rhs)]))+ <- dsInfo info+ case (resK, lhs) of+ (DStarK, [DVarT _]) -> [| True |]+ _ -> do+ runIO $ do+ putStrLn "Failed bug8884 test:"+ putStrLn $ show dinfo+ [| False |] )++flatten_dvald :: Bool+flatten_dvald = let s1 = $(flatten_dvald_test)+ s2 = $(do exp <- flatten_dvald_test+ DLetE ddecs dexp <- dsExp exp+ flattened <- fmap concat $ mapM flattenDValD ddecs+ return $ expToTH $ DLetE flattened dexp ) in+ s1 == s2++test_rec_sels :: Bool+test_rec_sels = and $(do bools <- mapM testRecSelTypes [1..rec_sel_test_num_sels]+ return $ ListE bools)+ main :: IO () main = hspec $ do describe "th-desugar library" $ do it "compiles" $ True it "expands" $ test_expand++ zipWithM (\num success -> it ("passes dec test " ++ show num) success)+ dec_test_nums test_dec++ -- instance test 1 is part of dectest 6.+ it "passes instance test" $ $(do ty <- [t| Int -> Bool |]+ [inst1, inst2] <- reifyInstances ''Show [ty]+ inst1 `eqTHSplice` inst2)++#if __GLASGOW_HASKELL__ < 707+ it "passes roles test" $ (decsToTH [ds_role_test]) `eqTH` role_test+#endif++ it "makes type names" $ test_mkName++ it "fixes bug 8884" $ test_bug8884++ it "flattens DValDs" $ flatten_dvald++ it "extract record selectors" $ test_rec_sels fromHUnitTest tests
Test/Splices.hs view
@@ -7,7 +7,8 @@ {-# LANGUAGE TemplateHaskell, LambdaCase, MagicHash, UnboxedTuples, MultiWayIf, ParallelListComp, CPP, BangPatterns, ScopedTypeVariables, RankNTypes, TypeFamilies, ImpredicativeTypes,- DataKinds, PolyKinds #-}+ DataKinds, PolyKinds, GADTs, MultiParamTypeClasses,+ FunctionalDependencies, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-name-shadowing #-} @@ -20,10 +21,45 @@ import Language.Haskell.TH import Language.Haskell.TH.Desugar import Language.Haskell.TH.Desugar.Sweeten+import Data.Generics +#if __GLASGOW_HASKELL__ < 707+data Proxy a = Proxy+#endif+ dsSplice :: Q Exp -> Q Exp dsSplice expq = expq >>= dsExp >>= (return . expToTH) +dsDecSplice :: Q [Dec] -> Q [Dec]+dsDecSplice decsQ = decsQ >>= dsDecs >>= (return . decsToTH)++testDecSplice :: Int -> Q Exp+testDecSplice n = do+ let dsName = mkName $ "Test.DsDec.Dec" ++ show n+ regName = mkName $ "Test.Dec.Dec" ++ show n+ infoDs <- reify dsName+ infoReg <- reify regName+#if __GLASGOW_HASKELL__ < 707+ eqTHSplice infoDs infoReg+#else+ rolesDs <- reifyRoles dsName+ rolesReg <- reifyRoles regName+ eqTHSplice (infoDs, rolesDs) (infoReg, rolesReg)+#endif++unqualify :: Data a => a -> a+unqualify = everywhere (mkT (mkName . nameBase))++eqTH :: (Data a, Show a) => a -> a -> Bool+eqTH a b = show (unqualify a) == show (unqualify b)++eqTHSplice :: (Data a, Show a) => a -> a -> Q Exp+eqTHSplice a b =+ if a `eqTH` b+ then [| True |]+ else [| False |]++ 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]) |]@@ -83,9 +119,6 @@ f x = x + 10 in (f 5, f 3.0) |] -data Proxy a = Proxy- deriving Show- test27_kisig = [| let f :: Proxy (a :: Bool) -> () f _ = () in (f (Proxy :: Proxy False), f (Proxy :: Proxy True)) |]@@ -134,3 +167,88 @@ f x = x in (f ()) |] #endif++#if __GLASGOW_HASKELL__ < 707+dec_test_nums = [1..9] :: [Int]+#else+dec_test_nums = [1..10] :: [Int]+#endif++dectest1 = [d| data Dec1 = Foo | Bar Int |]+dectest2 = [d| data Dec2 a = forall b. (Show b, Eq a) => MkDec2 a b Bool |]+dectest3 = [d| data Dec3 a = forall b. MkDec3 { foo :: a, bar :: b }+#if __GLASGOW_HASKELL__ >= 707+ type role Dec3 nominal+#endif+ |]+dectest4 = [d| newtype Dec4 a = MkDec4 (a, Int) |]+dectest5 = [d| type Dec5 a b = (a b, Maybe b) |]+dectest6 = [d| class (Monad m1, Monad m2) => Dec6 (m1 :: * -> *) m2 | m1 -> m2 where+ lift :: forall a. m1 a -> m2 a+ type M2 m1 :: * -> * |]+dectest7 = [d| type family Dec7 a (b :: *) (c :: Bool) :: * -> * |]+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 ''[]) ]+dectest10 = [d| type family Dec10 a :: * -> *+ type instance Dec10 Int = Maybe+ type instance Dec10 Bool = [] |]++ds_role_test = DRoleAnnotD (mkName "Dec3") [Nominal]+role_test = []+#else+dectest10 = [d| type family Dec10 a :: * -> * where+ Dec10 Int = Maybe+ Dec10 Bool = [] |]+#endif++instance_test = [d| instance (Show a, Show b) => Show (a -> b) where+ show _ = "function" |]++class Dec6 a b where { lift :: a x -> b x; type M2 a }+imp_inst_test1 = [d| instance Dec6 Maybe (Either ()) where+ lift Nothing = Left ()+ lift (Just x) = Right x+ type M2 Maybe = Either () |]++data family Dec9 a (b :: * -> *) :: * -> *+imp_inst_test2 = [d| data instance Dec9 Int Maybe a = MkIMB [a] | forall b. MkIMB2 (b a) |]+imp_inst_test3 = [d| newtype instance Dec9 Bool m x = MkBMX (m x) |]++type family Dec8 a+imp_inst_test4 = [d| type instance Dec8 Int = Bool |]++-- used for bug8884 test+type family Poly (a :: k) :: *+type instance Poly x = Int++flatten_dvald_test = [| let (a,b,c) = ("foo", 4, False) in+ show a ++ show b ++ show c |]++rec_sel_test = [d| data RecordSel a = forall b. (Show a, Eq b) =>+ MkRecord { recsel1 :: (Int, a)+ , recsel_naughty :: (a, b)+ , recsel2 :: (forall b. b -> a)+ , recsel3 :: Bool }+ | MkRecord2 { recsel4 :: (a, a) } |]+rec_sel_test_num_sels = 4 :: Int -- exclude naughty one++testRecSelTypes :: Int -> Q Exp+testRecSelTypes n = do+ VarI _ ty1 _ _ <- reify (mkName ("Test.DsDec.recsel" ++ show n))+ VarI _ ty2 _ _ <- reify (mkName ("Test.Dec.recsel" ++ show n))+ let ty1' = return $ unqualify ty1+ ty2' = return $ unqualify ty2+ [| let x :: $ty1'+ x = undefined+ y :: $ty2'+ y = undefined+ in+ $(return $ VarE $ mkName "hasSameType") x y |]++
th-desugar.cabal view
@@ -1,5 +1,5 @@ name: th-desugar-version: 1.3.1+version: 1.4.0 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.3.1+ tag: v1.4.0 library build-depends: @@ -38,7 +38,8 @@ exposed-modules: Language.Haskell.TH.Desugar, Language.Haskell.TH.Desugar.Sweeten, Language.Haskell.TH.Desugar.Expand- other-modules: Language.Haskell.TH.Desugar.Core, Language.Haskell.TH.Desugar.Util+ other-modules: Language.Haskell.TH.Desugar.Core,+ Language.Haskell.TH.Desugar.Util default-language: Haskell2010 @@ -47,7 +48,7 @@ ghc-options: -Wall -Werror -main-is Test.Run default-language: Haskell2010 main-is: Test/Run.hs- other-modules: Test.Splices+ other-modules: Test.Splices, Test.Dec, Test.DsDec build-depends: base >= 4 && < 5,