th-abstraction 0.2.0.0 → 0.2.1.0
raw patch · 5 files changed
+146/−20 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +6/−0
- src/Language/Haskell/TH/Datatype.hs +73/−12
- test/Harness.hs +18/−7
- test/Main.hs +48/−0
- th-abstraction.cabal +1/−1
ChangeLog.md view
@@ -1,5 +1,11 @@ # Revision history for th-abstraction +## 0.2.1.0 -- 2017-06-09++* Add sensible reify defaults and error messages when we+ can't backport fixes to old GHC Template Haskell output+ due to hand-written Decs being processed.+ ## 0.2.0.0 -- 2017-06-03 * Added `reifyFixityCompat`
src/Language/Haskell/TH/Datatype.hs view
@@ -413,6 +413,19 @@ -- | Normalize 'Dec' for a newtype or datatype into a 'DatatypeInfo'. -- Fail in 'Q' otherwise.+--+-- Beware: 'normalizeDec' can have surprising behavior when it comes to fixity.+-- For instance, if you have this quasiquoted data declaration:+--+-- [d| infix 5 :^^:+-- data Foo where+-- (:^^:) :: Int -> Int -> Foo |]+--+-- Then if you pass the 'Dec' for @Foo@ to 'normalizeDec' without splicing it+-- in a previous Template Haskell splice, then @(:^^:) will be labeled a 'NormalConstructor'+-- instead of an 'InfixConstructor'. This is because Template Haskell has no way to+-- reify the fixity declaration for @(:^^:)@, so it must assume there isn't one. To+-- work around this behavior, use 'reifyDatatype' instead. normalizeDec :: Dec -> Q DatatypeInfo #if MIN_VERSION_template_haskell(2,12,0) normalizeDec (NewtypeD context name tyvars _kind con _derives) =@@ -504,7 +517,9 @@ checkGadtFixity :: [Type] -> Name -> Q ConstructorVariant checkGadtFixity ts n = do #if MIN_VERSION_template_haskell(2,11,0)- mbFi <- reifyFixity n+ -- Don't call reifyFixityCompat here! We need to be able to distinguish+ -- between a default fixity and an explicit @infixl 9@.+ mbFi <- return Nothing `recover` reifyFixity n let userSuppliedFixity = isJust mbFi #else -- On old GHCs, there is a bug where infix GADT constructors will@@ -521,8 +536,8 @@ -- there is no way to distinguish between a user-supplied fixity of -- infixl 9 and the fixity that GHC defaults to, so we cannot properly -- handle that case.- DataConI _ _ _ fi <- reify n- let userSuppliedFixity = fi /= defaultFixity+ mbFi <- reifyFixityCompat n+ let userSuppliedFixity = isJust mbFi && mbFi /= Just defaultFixity #endif return $ if isInfixDataCon (nameBase n) && length ts == 2@@ -604,7 +619,14 @@ -> ConstructorVariant -> Q [ConstructorInfo] dataFamCase' n tyvars stricts variant = do- info <- reify n+ info <- reifyRecover n $ fail $ unlines+ [ "normalizeCon: Cannot reify constructor " ++ nameBase n+ , "You are likely calling normalizeDec on GHC 7.6 or 7.8 on a data family"+ , "whose type variables have been eta-reduced due to GHC Trac #9692."+ , "Unfortunately, without being able to reify the constructor's type,"+ , "there is no way to recover the eta-reduced type variables in general."+ , "A recommended workaround is to use reifyDatatype instead."+ ] case info of DataConI _ ty _ _ -> do let (context, argTys :|- returnTy) = uncurryType ty@@ -623,14 +645,45 @@ returnTy' argTys stricts (const $ return variant) _ -> fail "normalizeCon: impossible" + -- A very ad hoc way of determining if we need to perform some extra passes+ -- to repair an eta-reduction bug for data family instances that only occurs+ -- with GHC 7.6 and 7.8. We want to avoid doing these passes if at all possible,+ -- since they require reifying extra information, and reifying during+ -- normalization can be problematic for locally declared Template Haskell+ -- splices (see ##22).+ mightHaveBeenEtaReduced :: [Type] -> Bool+ mightHaveBeenEtaReduced ts =+ case unsnoc ts of+ Nothing -> False+ Just (initTs,lastT) ->+ case varTName lastT of+ Nothing -> False+ Just n -> not (n `elem` freeVariables initTs)++ -- If the list is empty returns 'Nothing', otherwise returns the 'init' and the 'last'.+ unsnoc :: [a] -> Maybe ([a], a)+ unsnoc [] = Nothing+ unsnoc [x] = Just ([], x)+ unsnoc (x:xs) = Just (x:a, b)+ where Just (a,b) = unsnoc xs++ -- If a Type is a VarT, find Just its Name. Otherwise, return Nothing.+ varTName :: Type -> Maybe Name+ varTName (SigT t _) = varTName t+ varTName (VarT n) = Just n+ varTName _ = Nothing+ in case variant of -- On GHC 7.6 and 7.8, there's quite a bit of post-processing that -- needs to be performed to work around an old bug that eta-reduces the -- type patterns of data families.- DataInstance -> dataFamCompatCase- NewtypeInstance -> dataFamCompatCase- Datatype -> defaultCase- Newtype -> defaultCase+ DataInstance+ | mightHaveBeenEtaReduced params+ -> dataFamCompatCase+ NewtypeInstance+ | mightHaveBeenEtaReduced params+ -> dataFamCompatCase+ _ -> defaultCase #else in defaultCase #endif@@ -720,7 +773,8 @@ case f of ConT n ->- do info <- reify n+ do info <- reifyRecover n $ fail+ "resolveTypeSynonyms: Cannot reify type synonym information" case info of TyConI (TySynD _ synvars def) -> let argNames = map tvName synvars@@ -793,7 +847,7 @@ go :: [(Type,Name,Fixity)] -> InfixList -> TypeQ go ts (ILNil u) = return (foldl (\acc (l,o,_) -> ConT o `AppT` l `AppT` acc) u ts) go ts (ILCons l o r) =- do ofx <- fromMaybe defaultFixity <$> reifyFixity o+ do ofx <- fromMaybe defaultFixity <$> reifyFixityCompat o let push = go ((l,o,ofx):ts) r case ts of (l1,o1,o1fx):ts' ->@@ -1156,9 +1210,9 @@ -- indicates that the answer is unavailable. reifyFixityCompat :: Name -> Q (Maybe Fixity) #if MIN_VERSION_template_haskell(2,11,0)-reifyFixityCompat n = (`mplus` Just defaultFixity) <$> reifyFixity n+reifyFixityCompat n = recover (return Nothing) ((`mplus` Just defaultFixity) <$> reifyFixity n) #else-reifyFixityCompat n =+reifyFixityCompat n = recover (return Nothing) $ do info <- reify n return $! case info of ClassOpI _ _ _ fixity -> Just fixity@@ -1166,3 +1220,10 @@ VarI _ _ _ fixity -> Just fixity _ -> Nothing #endif++-- | Call 'reify' with an action to take if reification fails.+reifyRecover ::+ Name ->+ Q Info {- ^ handle failure -} ->+ Q Info+reifyRecover n failure = failure `recover` reify n
test/Harness.hs view
@@ -12,7 +12,11 @@ up to alpha renaming. -}-module Harness (validate, varKCompat) where+module Harness+ ( validate+ , equateDI+ , varKCompat+ ) where import Control.Monad import qualified Data.Map as Map@@ -27,10 +31,10 @@ -- otherwise return a string exlaining the mismatch. equateDI :: DatatypeInfo -> DatatypeInfo -> Either String () equateDI dat1 dat2 =- do check "datatypeName" datatypeName dat1 dat2- check "datatypeVars len" (length . datatypeVars) dat1 dat2- check "datatypeVariant" datatypeVariant dat1 dat2- check "datatypeCons len" (length . datatypeCons) dat1 dat2+ do check "datatypeName" (nameBase . datatypeName) dat1 dat2+ check "datatypeVars len" (length . datatypeVars) dat1 dat2+ check "datatypeVariant" datatypeVariant dat1 dat2+ check "datatypeCons len" (length . datatypeCons) dat1 dat2 let sub = Map.fromList (zip (freeVariables (datatypeVars dat2)) (map VarT (freeVariables (datatypeVars dat1))))@@ -56,8 +60,8 @@ -- otherwise return a string exlaining the mismatch. equateCI :: ConstructorInfo -> ConstructorInfo -> Either String () equateCI con1 con2 =- do check "constructorName" constructorName con1 con2- check "constructorVariant" constructorVariant con1 con2+ do check "constructorName" (nameBase . constructorName) con1 con2+ check "constructorVariant" constructorVariantBase con1 con2 let sub = Map.fromList (zip (map tvName (constructorVars con2)) (map VarT (map tvName (constructorVars con1))))@@ -73,6 +77,13 @@ zipWithM_ equateStrictness (constructorStrictness con1) (constructorStrictness con2)+ where+ constructorVariantBase :: ConstructorInfo -> ConstructorVariant+ constructorVariantBase con =+ case constructorVariant con of+ NormalConstructor -> NormalConstructor+ i@InfixConstructor{} -> i+ RecordConstructor fields -> RecordConstructor $ map (mkName . nameBase) fields equateStrictness :: FieldStrictness -> FieldStrictness -> Either String () equateStrictness fs1 fs2 =
test/Main.hs view
@@ -86,6 +86,8 @@ MkGadtFam5 :: (q ~ Char) => q -> GadtFam Bool Bool infixl 3 :&&: +data family FamLocalDec1 a+data family FamLocalDec2 a b c #endif return [] -- segment type declarations above from refiy below@@ -107,6 +109,8 @@ ghc78bugTest polyTest gadtFamTest+ famLocalDecTest1+ famLocalDecTest2 #endif fixityLookupTest @@ -476,6 +480,50 @@ , constructorFields = [qTy] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } ]+ }+ )++famLocalDecTest1 :: IO ()+famLocalDecTest1 =+ $(do [dec] <- [d| data instance FamLocalDec1 Int = FamLocalDec1Int { mochi :: Double } |]+ info <- normalizeDec dec+ validate info+ DatatypeInfo+ { datatypeName = ''FamLocalDec1+ , datatypeContext = []+ , datatypeVars = [ConT ''Int]+ , datatypeVariant = DataInstance+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = mkName "FamLocalDec1Int"+ , constructorVars = []+ , constructorContext = []+ , constructorFields = [ConT ''Double]+ , constructorStrictness = [notStrictAnnot]+ , constructorVariant = RecordConstructor [mkName "mochi"] }]+ }+ )++famLocalDecTest2 :: IO ()+famLocalDecTest2 =+ $(do [dec] <- [d| data instance FamLocalDec2 Int (a, b) a = FamLocalDec2Int { fm0 :: (b, a), fm1 :: Int } |]+ info <- normalizeDec dec+ let tys@[a,b] = map (VarT . mkName) ["a", "b"]+ [aSig,bSig] = map (\v -> SigT v starK) tys+ validate info+ DatatypeInfo+ { datatypeName = ''FamLocalDec2+ , datatypeContext = []+ , datatypeVars = [ConT ''Int, TupleT 2 `AppT` a `AppT` b, aSig]+ , datatypeVariant = DataInstance+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = mkName "FamLocalDec2Int"+ , constructorVars = []+ , constructorContext = []+ , constructorFields = [TupleT 2 `AppT` b `AppT` a, ConT ''Int]+ , constructorStrictness = [notStrictAnnot, notStrictAnnot]+ , constructorVariant = RecordConstructor [mkName "fm0", mkName "fm1"] }] } ) #endif
th-abstraction.cabal view
@@ -1,5 +1,5 @@ name: th-abstraction-version: 0.2.0.0+version: 0.2.1.0 synopsis: Nicer interface for reified information about data types description: This package normalizes variations in the interface for inspecting datatype information via Template Haskell