diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/src/Language/Haskell/TH/Datatype.hs b/src/Language/Haskell/TH/Datatype.hs --- a/src/Language/Haskell/TH/Datatype.hs +++ b/src/Language/Haskell/TH/Datatype.hs @@ -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 diff --git a/test/Harness.hs b/test/Harness.hs --- a/test/Harness.hs +++ b/test/Harness.hs @@ -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 = diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/th-abstraction.cabal b/th-abstraction.cabal --- a/th-abstraction.cabal +++ b/th-abstraction.cabal @@ -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