th-abstraction 0.1.1.0 → 0.1.2.0

raw patch · 5 files changed

+119/−20 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−1
• src/Language/Haskell/TH/Datatype.hs +52/−10
• test/Harness.hs +5/−1
• test/Main.hs +54/−7
• th-abstraction.cabal +1/−1

@@ -1,6 +1,12 @@ # Revision history for th-abstraction -## 0.1.1.0  --+## 0.1.2.0  -- 2017-05-21++* Added `arrowKCompat`+* Added workaround for GHC 7.8 data instance eta reduction bug+* Added kind signatures to datatypeVars++## 0.1.1.0  -- 2017-05-20  * Better matching of constraints generated for GADTs across GHC versions * Added `dataDCompat`

@@ -67,6 +67,7 @@    -- * Backward compatible data definitions   , dataDCompat+  , arrowKCompat    -- * Convenience functions   , resolveTypeSynonyms@@ -83,6 +84,7 @@ import           Control.Monad (foldM) import           GHC.Generics (Generic) import           Language.Haskell.TH+import           Language.Haskell.TH.Lib (arrowK) -- needed for th-2.4  #if !MIN_VERSION_base(4,8,0) import           Control.Applicative (Applicative(..), (<$>))@@ -146,27 +148,57 @@ normalizeInfo :: Info -> Q DatatypeInfo normalizeInfo (TyConI dec) = normalizeDec dec # if MIN_VERSION_template_haskell(2,11,0)-normalizeInfo (DataConI name _ parent) = reifyParent name parent+normalizeInfo (DataConI name ty parent) = reifyParent name ty parent # else-normalizeInfo (DataConI name _ parent _) = reifyParent name parent+normalizeInfo (DataConI name ty parent _) = reifyParent name ty parent # endif normalizeInfo _ = fail "reifyDatatype: Expected a type constructor"  -reifyParent :: Name -> Name -> Q DatatypeInfo-reifyParent con parent =+reifyParent :: Name -> Type -> Name -> Q DatatypeInfo+reifyParent con ty parent =   do info <- reify parent      case info of        TyConI dec -> normalizeDec dec-       FamilyI _ instances ->-         do instances' <- traverse normalizeDec instances-            case find p instances' of-              Nothing -> fail "PANIC: reifyParent lost the instance"-              Just dec -> return dec+       FamilyI dec instances ->+         do let instances1 = map (repairInstance dec ty) instances+            instances2 <- traverse normalizeDec instances1+            case find p instances2 of+              Just inst -> return inst+              Nothing   -> fail "PANIC: reifyParent lost the instance"+       _ -> fail "PANIC: reifyParent unexpected parent"   where     p info = con `elem` map constructorName (datatypeCons info) +#if (!MIN_VERSION_template_haskell(2,10,0)) && MIN_VERSION_template_haskell(2,9,0)+    kindPart (KindedTV _ k) = [k]+    kindPart (PlainTV  _  ) = [] +    countKindVars = length . freeVariables . map kindPart+    -- GHC 7.8.4 will eta-reduce data instances. We can find the missing+    -- type variables on the data constructor.+    repairInstance+      (FamilyD _ _ dvars _)+      (ForallT tvars _ _)+      (NewtypeInstD cx n ts con deriv) =+        NewtypeInstD cx n ts' con deriv+      where+        nparams = length dvars+        kparams = countKindVars dvars+        ts'     = take nparams (drop kparams (ts ++ bndrParams tvars))+    repairInstance+      (FamilyD _ _ dvars _)+      (ForallT tvars _ _)+      (DataInstD cx n ts cons deriv) =+        DataInstD cx n ts' cons deriv+      where+        nparams = length dvars+        kparams = countKindVars dvars+        ts'     = take nparams (drop kparams (ts ++ bndrParams tvars))+#endif+    repairInstance _ _ x = x++ -- | Normalize 'Dec' for a newtype or datatype into a 'DatatypeInfo'. -- Fail in 'Q' otherwise. normalizeDec :: Dec -> Q DatatypeInfo@@ -207,7 +239,10 @@ normalizeDec _ = fail "reifyDatatype: DataD or NewtypeD required"  bndrParams :: [TyVarBndr] -> [Type]-bndrParams = map (VarT . tvName)+bndrParams = map $ \bndr ->+  case bndr of+    KindedTV t k -> SigT (VarT t) k+    PlainTV  t   -> VarT t   normalizeDec' ::@@ -580,4 +615,11 @@     (pure (map ConT ds)) #else dataDCompat = dataD+#endif++arrowKCompat :: Kind -> Kind -> Kind+#if MIN_VERSION_template_haskell(2,8,0)+arrowKCompat x y = arrowK `appK` x `appK` y+#else+arrowKCompat = arrowK #endif

@@ -22,6 +22,10 @@ validate :: DatatypeInfo -> DatatypeInfo -> ExpQ validate x y = either fail (\_ -> [| return () |]) (equateDI x y) +stripOuterSigT :: Type -> Type+stripOuterSigT (SigT t _) = t+stripOuterSigT t          = t+ -- | If the arguments are equal up to renaming return @'Right' ()@, -- otherwise return a string exlaining the mismatch. equateDI :: DatatypeInfo -> DatatypeInfo -> Either String ()@@ -39,7 +43,7 @@        (applySubstitution sub (datatypeContext dat2))       check "datatypeVars" id-       (datatypeVars dat1)+       (map stripOuterSigT (datatypeVars dat1))        (applySubstitution sub (datatypeVars dat2))       zipWithM_ equateCI

@@ -1,4 +1,4 @@-{-# Language TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-}+{-# Language CPP, PolyKinds, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-}  {-| Module      : Main@@ -14,7 +14,6 @@ -} module Main (main) where -import Control.Monad import Language.Haskell.TH import Language.Haskell.TH.Datatype @@ -22,11 +21,11 @@  type Gadt1Int = Gadt1 Int -data Gadt1 a where+data Gadt1 (a :: *) where   Gadtc1 :: Int   -> Gadt1Int   Gadtc2 :: (a,a) -> Gadt1 a -data Adt1 a b = Adtc1 (a,b) | Bool `Adtc2` Int+data Adt1 (a :: *) (b :: *) = Adtc1 (a,b) | Bool `Adtc2` Int  data Gadtrec1 a where   Gadtrecc1, Gadtrecc2 :: { gadtrec1a :: a, gadtrec1b :: b } -> Gadtrec1 (a,b)@@ -44,9 +43,20 @@   Gadt2c2 :: Gadt2 [a] a   Gadt2c3 :: Gadt2 [a] [a] -data family DF a+data family DF (a :: *) data instance DF (Maybe a) = DFMaybe Int [a] +#if MIN_VERSION_template_haskell(2,9,0)+data family DF1 (a :: k)+#elif MIN_VERSION_template_haskell(2,8,0)+data family DF1 a+#else+data family DF1 (a :: *)+#endif+data instance DF1 b = DF1 b++data VoidStoS (f :: * -> *)+ return [] -- segment type declarations above from refiy below  -- | Test entry point. Tests will pass or fail at compile time.@@ -54,11 +64,14 @@ main =   do adt1Test      gadt1Test+     gadt2Test      gadtrec1Test      equalTest      showableTest      recordTest      dataFamilyTest+     ghc78bugTest+     voidstosTest  adt1Test :: IO () adt1Test =@@ -154,7 +167,7 @@          DatatypeInfo            { datatypeName    = ''Equal            , datatypeContext = []-           , datatypeVars    = [a,b,c]+           , datatypeVars    = [a, b, c]            , datatypeVariant = Datatype            , datatypeCons    =                [ ConstructorInfo@@ -227,7 +240,7 @@          DatatypeInfo            { datatypeName    = ''Gadt2            , datatypeContext = []-           , datatypeVars    = [a,b]+           , datatypeVars    = [a, b]            , datatypeVariant = Datatype            , datatypeCons    =                [ con { constructorName = 'Gadt2c1@@ -259,5 +272,39 @@                    , constructorContext = []                    , constructorFields  = [ConT ''Int, ListT `AppT` VarT a]                    , constructorVariant = NormalConstructor } ]+           }+  )++ghc78bugTest :: IO ()+ghc78bugTest =+  $(do info <- reifyDatatype 'DF1+       let c = mkName "c"+       validate info+         DatatypeInfo+           { datatypeName    = ''DF1+           , datatypeContext = []+           , datatypeVars    = [VarT c]+           , datatypeVariant = DataInstance+           , datatypeCons    =+               [ ConstructorInfo+                   { constructorName    = 'DF1+                   , constructorVars    = []+                   , constructorContext = []+                   , constructorFields  = [VarT c]+                   , constructorVariant = NormalConstructor } ]+           }+  )++voidstosTest :: IO ()+voidstosTest =+  $(do info <- reifyDatatype ''VoidStoS+       let g = mkName "g"+       validate info+         DatatypeInfo+           { datatypeName    = ''VoidStoS+           , datatypeContext = []+           , datatypeVars    = [VarT g]+           , datatypeVariant = Datatype+           , datatypeCons    = []            }   )

@@ -1,5 +1,5 @@ name:                th-abstraction-version:             0.1.1.0+version:             0.1.2.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