th-desugar 1.4.1 → 1.4.2
raw patch · 5 files changed
+87/−17 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGES.md +5/−0
- Language/Haskell/TH/Desugar/Expand.hs +62/−14
- Test/Run.hs +7/−1
- Test/Splices.hs +11/−0
- th-desugar.cabal +2/−2
CHANGES.md view
@@ -1,3 +1,8 @@+Version 1.4.2+-------------+* `expand` functions now consider open type families, as long as the type+ to be expanded has no free variables.+ Version 1.4.1 ------------- * Added `Language.Haskell.TH.Desugar.Lift`, which provides `Lift` instances
Language/Haskell/TH/Desugar/Expand.hs view
@@ -4,7 +4,7 @@ eir@cis.upenn.edu -} -{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, NoMonomorphismRestriction #-} ----------------------------------------------------------------------------- -- |@@ -15,8 +15,9 @@ -- Stability : experimental -- Portability : non-portable ----- Expands type synonyms in desugared types, ignoring type families.--- See also the package th-expand-syns for doing this to non-desugared types.+-- 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+-- non-desugared types. -- ---------------------------------------------------------------------------- @@ -31,11 +32,14 @@ import Language.Haskell.TH.Syntax ( Quasi(..) ) import Data.Data import Data.Generics+import Data.Monoid import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util+import Language.Haskell.TH.Desugar.Sweeten --- | Expands all type synonyms in a desugared type.+-- | Expands all type synonyms in a desugared type. Also expands open type family+-- applications, as long as the arguments have no free variables. expandType :: Quasi q => DType -> q DType expandType = go [] where@@ -74,17 +78,60 @@ -> q DType -- ^ Expanded type expandCon n args = do info <- reifyWithWarning n- case info of- TyConI (TySynD _n tvbs rhs)- | length args >= length tvbs -> do+ dinfo <- dsInfo info+ case dinfo of+ DTyConI (DTySynD _n tvbs rhs) _+ | length args >= length tvbs -- this should always be true!+ -> do let (syn_args, rest_args) = splitAtList tvbs args- rhs' <- dsType rhs- rhs'' <- expandType rhs'- tvbs' <- mapM dsTvb tvbs- ty <- substTy (M.fromList $ zip (map extractDTvbName tvbs') syn_args) rhs''- return $ foldl DAppT ty rest_args+ ty <- substTy (M.fromList $ zip (map extractDTvbName tvbs) syn_args) rhs+ ty' <- expandType ty+ return $ foldl DAppT ty' rest_args++ DTyConI (DFamilyD TypeFam _n tvbs _mkind) _+ | length args >= length tvbs -- this should always be true!+ , all no_tyvars args+ -> do+ let (syn_args, rest_args) = splitAtList tvbs args+ -- need to get the correct instance+ insts <- qReifyInstances n (map typeToTH syn_args)+ dinsts <- dsDecs insts+ case dinsts of+ [DTySynInstD _n (DTySynEqn lhs rhs)] -> do+ let subst = mconcat $ zipWith build_subst lhs syn_args+ ty <- substTy subst rhs+ ty' <- expandType ty+ return $ foldl DAppT ty' rest_args+ _ -> return $ foldl DAppT (DConT n) args+ _ -> return $ foldl DAppT (DConT n) args + where+ no_tyvars :: Data a => a -> Bool+ no_tyvars = everything (&&) (mkQ True no_tyvar)++ no_tyvar :: DType -> Bool+ no_tyvar (DVarT _) = False+ no_tyvar t = gmapQl (&&) True no_tyvars t++ build_subst :: DType -> DType -> M.Map Name DType+ build_subst (DVarT var_name) arg = M.singleton var_name arg+ -- ignore kind signatures; any kind constraints are already+ -- handled in reifyInstances+ build_subst pat (DSigT ty _ki) = build_subst pat ty+ build_subst (DSigT ty _ki) arg = build_subst ty arg+ build_subst (DForallT {}) _ =+ error "Impossible: forall-quantified pattern to type family"+ -- reifyInstances should fail if an argument is forall-quantified.+ build_subst _ (DForallT {}) =+ error "Impossible: forall-quantified argument to type family"+ build_subst (DAppT pat1 pat2) (DAppT arg1 arg2) =+ build_subst pat1 arg1 <> build_subst pat2 arg2+ build_subst (DConT _pat_con) (DConT _arg_con) = mempty+ build_subst DArrowT DArrowT = mempty+ build_subst (DLitT _pat_lit) (DLitT _arg_lit) = mempty+ build_subst pat arg = error $ "Impossible: reifyInstances succeeded but unification failed; pat=" ++ show pat ++ "; arg=" ++ show arg+ -- | Capture-avoiding substitution on types substTy :: Quasi q => M.Map Name DType -> DType -> q DType substTy vars (DForallT tvbs cxt ty) =@@ -142,7 +189,8 @@ dTypeToDPred (DLitT _) = impossible "Type literal used as head of constraint" --- | Expand all type synonyms in the desugared abstract syntax tree provided.--- Normally, the first parameter should have a type like 'DExp' or 'DLetDec'.+-- | Expand all type synonyms and open type families in the desugared abstract+-- syntax tree provided. Normally, the first parameter should have a type like+-- 'DExp' or 'DLetDec'. expand :: (Quasi q, Data a) => a -> q a expand = everywhereM (mkM expandType >=> mkM expandPred)
Test/Run.hs view
@@ -84,13 +84,19 @@ test35b = $(test35_expand >>= dsExp >>= expand >>= return . expToTH) test36a = $test36_expand test36b = $(test36_expand >>= dsExp >>= expand >>= return . expToTH)+test_e3a = $test_expand3+test_e3b = $(test_expand3 >>= dsExp >>= expand >>= return . expToTH)+test_e4a = $test_expand4+test_e4b = $(test_expand4 >>= dsExp >>= expand >>= return . expToTH) hasSameType :: a -> a -> Bool hasSameType _ _ = True test_expand :: Bool test_expand = and [ hasSameType test35a test35b- , hasSameType test36a test36b]+ , hasSameType test36a test36b+ , hasSameType test_e3a test_e3b+ , hasSameType test_e4a test_e4b ] test_dec :: [Bool] test_dec = $(do bools <- mapM testDecSplice dec_test_nums
Test/Splices.hs view
@@ -154,6 +154,16 @@ f = snd in f |] +type family TFExpand x+type instance TFExpand Int = Bool+type instance TFExpand (Maybe a) = [a]+test_expand3 = [| let f :: TFExpand Int -> ()+ f True = () in+ f |]+test_expand4 = [| let f :: TFExpand (Maybe Bool) -> ()+ f [True, False] = () in+ f |]+ #if __GLASGOW_HASKELL__ >= 709 test37_pred = [| let f :: (Read a, (Show a, Num a)) => a -> a f x = read (show x) + x in@@ -252,3 +262,4 @@ $(return $ VarE $ mkName "hasSameType") x y |] +-- used for expand
th-desugar.cabal view
@@ -1,5 +1,5 @@ name: th-desugar-version: 1.4.1+version: 1.4.2 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.4.1+ tag: v1.4.2 library build-depends: