th-desugar 1.5.3 → 1.5.4

raw patch · 5 files changed

+98/−30 lines, 5 filesdep ~basedep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

• CHANGES.md +7/−0
• Language/Haskell/TH/Desugar/Expand.hs +63/−26
• Test/Run.hs +13/−0
• Test/Splices.hs +12/−1
• th-desugar.cabal +3/−3

@@ -1,3 +1,10 @@+`th-desugar` release notes+==========================++Version 1.5.4+-------------+* Added+ Version 1.5.3 ------------- * More `DsMonad` instances, thanks to David Fox.

@@ -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))

@@ -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                   ] 

@@ -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  

@@ -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,