diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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. diff --git a/Language/Haskell/TH/Desugar.hs b/Language/Haskell/TH/Desugar.hs --- a/Language/Haskell/TH/Desugar.hs +++ b/Language/Haskell/TH/Desugar.hs @@ -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 diff --git a/Language/Haskell/TH/Desugar/Core.hs b/Language/Haskell/TH/Desugar/Core.hs --- a/Language/Haskell/TH/Desugar/Core.hs +++ b/Language/Haskell/TH/Desugar/Core.hs @@ -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 diff --git a/Language/Haskell/TH/Desugar/Sweeten.hs b/Language/Haskell/TH/Desugar/Sweeten.hs --- a/Language/Haskell/TH/Desugar/Sweeten.hs +++ b/Language/Haskell/TH/Desugar/Sweeten.hs @@ -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 diff --git a/Language/Haskell/TH/Desugar/Util.hs b/Language/Haskell/TH/Desugar/Util.hs --- a/Language/Haskell/TH/Desugar/Util.hs +++ b/Language/Haskell/TH/Desugar/Util.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/Test/Dec.hs b/Test/Dec.hs new file mode 100644 --- /dev/null +++ b/Test/Dec.hs @@ -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) + diff --git a/Test/DsDec.hs b/Test/DsDec.hs new file mode 100644 --- /dev/null +++ b/Test/DsDec.hs @@ -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)) + diff --git a/Test/Run.hs b/Test/Run.hs --- a/Test/Run.hs +++ b/Test/Run.hs @@ -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 diff --git a/Test/Splices.hs b/Test/Splices.hs --- a/Test/Splices.hs +++ b/Test/Splices.hs @@ -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 |] + + diff --git a/th-desugar.cabal b/th-desugar.cabal --- a/th-desugar.cabal +++ b/th-desugar.cabal @@ -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,