diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,10 @@ +`th-desugar` release notes +========================== + +Version 1.5.4 +------------- +* Added + Version 1.5.3 ------------- * More `DsMonad` instances, thanks to David Fox. diff --git a/Language/Haskell/TH/Desugar/Expand.hs b/Language/Haskell/TH/Desugar/Expand.hs --- a/Language/Haskell/TH/Desugar/Expand.hs +++ b/Language/Haskell/TH/Desugar/Expand.hs @@ -15,14 +15,21 @@ -- Stability : experimental -- Portability : non-portable -- --- Expands type synonyms and open type families in desugared types, ignoring --- closed type families. See also the package th-expand-syns for doing this to +-- Expands type synonyms and type families in desugared types. +-- See also the package th-expand-syns for doing this to -- non-desugared types. -- ---------------------------------------------------------------------------- module Language.Haskell.TH.Desugar.Expand ( - expand, expandType, substTy + -- * Expand synonyms soundly + expand, expandType, + + -- * Expand synonyms potentially unsoundly + expandUnsoundly, + + -- * Capture-avoiding substitution + substTy ) where import qualified Data.Map as M @@ -43,47 +50,54 @@ import Language.Haskell.TH.Desugar.Sweeten import Language.Haskell.TH.Desugar.Reify +-- | Ignore kind annotations? +data IgnoreKinds = YesIgnore | NoIgnore + -- | Expands all type synonyms in a desugared type. Also expands open type family -- applications, as long as the arguments have no free variables. Attempts to -- expand closed type family applications, but aborts the moment it spots anything -- strange, like a nested type family application or type variable. expandType :: DsMonad q => DType -> q DType -expandType = go [] +expandType = expand_type NoIgnore + +expand_type :: DsMonad q => IgnoreKinds -> DType -> q DType +expand_type ign = go [] where go [] (DForallT tvbs cxt ty) = - DForallT tvbs <$> mapM expand cxt <*> expandType ty + DForallT tvbs <$> mapM (expand_ ign) cxt <*> expand_type ign ty go _ (DForallT {}) = impossible "A forall type is applied to another type." go args (DAppT t1 t2) = do - t2' <- expandType t2 + t2' <- expand_type ign t2 go (t2' : args) t1 go args (DSigT ty ki) = do ty' <- go [] ty return $ foldl DAppT (DSigT ty' ki) args - go args (DConT n) = expandCon n args + go args (DConT n) = expand_con ign n args go args ty = return $ foldl DAppT ty args -- | Expands all type synonyms in a desugared predicate. -expandPred :: DsMonad q => DPred -> q DPred -expandPred = go [] +expand_pred :: DsMonad q => IgnoreKinds -> DPred -> q DPred +expand_pred ign = go [] where go args (DAppPr p t) = do - t' <- expandType t + t' <- expand_type ign t go (t' : args) p go args (DSigPr p k) = do p' <- go [] p return $ foldl DAppPr (DSigPr p' k) args go args (DConPr n) = do - ty <- expandCon n args + ty <- expand_con ign n args dTypeToDPred ty go args p = return $ foldl DAppPr p args -- | Expand a constructor with given arguments -expandCon :: DsMonad q - => Name -- ^ Tycon name - -> [DType] -- ^ Arguments - -> q DType -- ^ Expanded type -expandCon n args = do +expand_con :: DsMonad q + => IgnoreKinds + -> Name -- ^ Tycon name + -> [DType] -- ^ Arguments + -> q DType -- ^ Expanded type +expand_con ign n args = do info <- reifyWithLocals n dinfo <- dsInfo info args_ok <- allM no_tyvars_tyfams args @@ -93,7 +107,7 @@ -> do let (syn_args, rest_args) = splitAtList tvbs args ty <- substTy (M.fromList $ zip (map extractDTvbName tvbs) syn_args) rhs - ty' <- expandType ty + ty' <- expand_type ign ty return $ foldl DAppT ty' rest_args DTyConI (DFamilyD TypeFam _n tvbs _mkind) _ @@ -110,7 +124,7 @@ expectJustM "Impossible: reification returned a bogus instance" $ merge_maps $ zipWith build_subst lhs syn_args ty <- substTy subst rhs - ty' <- expandType ty + ty' <- expand_type ign ty return $ foldl DAppT ty' rest_args _ -> return $ foldl DAppT (DConT n) args @@ -122,7 +136,7 @@ rhss <- mapMaybeM (check_eqn syn_args) eqns case rhss of (rhs : _) -> do - rhs' <- expandType rhs + rhs' <- expand_type ign rhs return $ foldl DAppT rhs' rest_args [] -> return $ foldl DAppT (DConT n) args @@ -132,7 +146,7 @@ check_eqn arg_tys (DTySynEqn lhs rhs) = do let m_subst = merge_maps $ zipWith build_subst lhs arg_tys T.mapM (flip substTy rhs) m_subst - + _ -> return $ foldl DAppT (DConT n) args where @@ -154,7 +168,9 @@ build_subst (DVarT var_name) arg = Just $ M.singleton var_name arg -- if a pattern has a kind signature, it's really easy to get -- this wrong. - build_subst (DSigT {}) _ = Nothing + build_subst (DSigT ty _ki) arg = case ign of + YesIgnore -> build_subst ty arg + NoIgnore -> Nothing -- but we can safely ignore kind signatures on the target build_subst pat (DSigT ty _ki) = build_subst pat ty build_subst (DForallT {}) _ = @@ -187,7 +203,6 @@ allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM f = foldM (\b x -> (b &&) `liftM` f x) True - -- | Capture-avoiding substitution on types substTy :: DsMonad q => M.Map Name DType -> DType -> q DType substTy vars (DForallT tvbs cxt ty) = @@ -244,9 +259,31 @@ dTypeToDPred DArrowT = impossible "Arrow used as head of constraint" dTypeToDPred (DLitT _) = impossible "Type literal used as head of constraint" - --- | Expand all type synonyms and open type families in the desugared abstract --- syntax tree provided. Normally, the first parameter should have a type like +-- | Expand all type synonyms and type families in the desugared abstract +-- syntax tree provided, where type family simplification is on a "best effort" +-- basis. Normally, the first parameter should have a type like -- 'DExp' or 'DLetDec'. expand :: (DsMonad q, Data a) => a -> q a -expand = everywhereM (mkM expandType >=> mkM expandPred) +expand = expand_ NoIgnore + +-- | Expand all type synonyms and type families in the desugared abstract +-- syntax tree provided, where type family simplification is on a "better +-- than best effort" basis. This means that it will try so hard that it will +-- sometimes do the wrong thing. Specifically, any kind parameters to type +-- families are ignored. So, if we have +-- +-- > type family F (x :: k) where +-- > F (a :: *) = Int +-- +-- 'expandUnsoundly' will expand @F 'True@ to @Int@, ignoring that the +-- expansion should only work for type of kind @*@. +-- +-- This function is useful because plain old 'expand' will simply fail +-- to expand type families that make use of kinds. Sometimes, the kinds +-- are benign and we want to expand anyway. Use this function in that case. +expandUnsoundly :: (DsMonad q, Data a) => a -> q a +expandUnsoundly = expand_ YesIgnore + +-- | Generalization of 'expand' that either can or won't ignore kind annotations.sx +expand_ :: (DsMonad q, Data a) => IgnoreKinds -> a -> q a +expand_ ign = everywhereM (mkM (expand_type ign) >=> mkM (expand_pred ign)) diff --git a/Test/Run.hs b/Test/Run.hs --- a/Test/Run.hs +++ b/Test/Run.hs @@ -25,6 +25,9 @@ import qualified Dec import Dec ( RecordSel ) import Language.Haskell.TH.Desugar +#if __GLASGOW_HASKELL__ >= 707 +import Language.Haskell.TH.Desugar.Expand ( expandUnsoundly ) +#endif import Language.Haskell.TH import qualified Language.Haskell.TH.Syntax as Syn ( lift ) @@ -113,6 +116,13 @@ test_e5b = $(test_expand5 >>= dsExp >>= expand >>= return . expToTH) test_e6a = $test_expand6 test_e6b = $(test_expand6 >>= dsExp >>= expand >>= return . expToTH) +test_e7a = $test_expand7 +test_e7b = $(test_expand7 >>= dsExp >>= expand >>= return . expToTH) +test_e7c = $(test_expand7 >>= dsExp >>= expandUnsoundly >>= return . expToTH) +test_e8a = $(test_expand8 >>= dsExp >>= expand >>= return . expToTH) + -- the line above should fail once GHC#8953 is fixed for closed type + -- families +test_e8b = $(test_expand8 >>= dsExp >>= expandUnsoundly >>= return . expToTH) #endif hasSameType :: a -> a -> Bool @@ -126,6 +136,9 @@ #if __GLASGOW_HASKELL__ >= 707 , hasSameType test_e5a test_e5b , hasSameType test_e6a test_e6b + , hasSameType test_e7a test_e7b + , hasSameType test_e7a test_e7c + , hasSameType test_e8a test_e8a #endif ] diff --git a/Test/Splices.hs b/Test/Splices.hs --- a/Test/Splices.hs +++ b/Test/Splices.hs @@ -195,6 +195,17 @@ test_expand6 = [| let f :: ClosedTF Double -> () f 'x' = () in f |] + +type family PolyTF (x :: k) :: * where + PolyTF (x :: *) = Bool + +test_expand7 = [| let f :: PolyTF Int -> () + f True = () in + f |] +test_expand8 = [| let f :: PolyTF IO -> () + f True = () in + f |] + #endif #if __GLASGOW_HASKELL__ >= 709 @@ -306,7 +317,7 @@ in $(return $ VarE $ mkName "hasSameType") x y |] - + -- used for expand 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.5.3 +version: 1.5.4 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell homepage: http://www.cis.upenn.edu/~eir/packages/th-desugar @@ -26,10 +26,10 @@ source-repository this type: git location: https://github.com/goldfirere/th-desugar.git - tag: v1.5.3 + tag: v1.5.4 library - build-depends: + build-depends: base >= 4 && < 5, template-haskell, containers >= 0.5,