th-typegraph 1.0 → 1.0.2

raw patch · 5 files changed

+20/−4 lines, 5 files

Files

• src/Language/Haskell/TH/TypeGraph/Orphans.hs +3/−0
• src/Language/Haskell/TH/TypeGraph/Phantom.hs +7/−0
• src/Language/Haskell/TH/TypeGraph/SafeCopyDerive.hs +7/−1
• src/Language/Haskell/TH/TypeGraph/TypeTraversal.hs +2/−2
• th-typegraph.cabal +1/−1

@@ -8,6 +8,9 @@ module Language.Haskell.TH.TypeGraph.Orphans where  import Data.Aeson (FromJSON(parseJSON), Value(Null), ToJSON(toJSON))+#if MIN_VERSION_aeson(1,0,0)+import Data.Aeson (ToJSONKey, FromJSONKey)+#endif #if !MIN_VERSION_aeson(0,11,0) import Data.Aeson.Types (typeMismatch) #endif

@@ -1,5 +1,6 @@ -- | Compute which type parameters are phantom types. +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -76,9 +77,15 @@     runQ (reify tname) >>= go     where       go :: DsMonad m => Info -> m [Type]+#if MIN_VERSION_template_haskell(2,11,0)+      go (TyConI (DataD _cx _tname binds _mkind _cons _supers)) = mapM (runQ . varT . toName) binds >>= go'+      go (TyConI (NewtypeD _cx _tname binds _mkind _con _supers)) = mapM (runQ . varT . toName) binds >>= go'+#else       go (TyConI (DataD _cx _tname binds _cons _supers)) = mapM (runQ . varT . toName) binds >>= go'       go (TyConI (NewtypeD _cx _tname binds _con _supers)) = mapM (runQ . varT . toName) binds >>= go'+#endif       go (TyConI (TySynD _tname binds _typ)) = mapM (runQ . varT . toName) binds >>= go'+      go x = error $ "th-typegraph:nonPhantom - expecting TyConI DataD/TyConI NewtypeD/TyConI TySynD, but found " ++ show x       go' :: DsMonad m => [Type] -> m [Type]       go' ps =           (Set.toList . view (_1 . result)) <$>

@@ -292,7 +292,7 @@ #else           safeCopyClass args = classP ''SafeCopy args #endif-      in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ var] | VarT var <- tyvars'] ++ map return context)+      in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ var] | VarT var <- tyvars'] ++ map return context ++ migrateFromKind ty kindName)                                        (conT ''SafeCopy `appT` ty)                                        [ mkPutCopy deriveType cons                                        , mkGetCopy deriveType (show tyName) cons@@ -300,6 +300,12 @@                                        , valD (varP 'kind) (normalB (varE kindName)) []                                        , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL (show tyName)) []]                                        ]+    -- This adds Migrate Foo to the superclasses of SafeCopy Foo if+    -- the kind is extension.  This lets us defer the actual+    -- implementation of the Migrate instance, which is harmless and+    -- sometimes useful.+    migrateFromKind ty name =+        if name == 'extension then [appT (conT ''Migrate) ty] else []  internalDeriveSafeCopyIndexedType :: DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec] internalDeriveSafeCopyIndexedType deriveType versionId kindName tyName tyIndex' = do

@@ -88,7 +88,7 @@ doTypeOnce go typ = unvisited typ (go typ)  doApply :: (HasTypeTraversal m, HasTypeParameters m, DsMonad m) => Type -> Type -> m ()-doApply typ0 (ForallT tvs cxt typ) = doApply typ0 typ+doApply typ0 (ForallT _tvs _cxt typ) = doApply typ0 typ doApply typ0 (VarT name) = doVarT typ0 name doApply typ0 (AppT a b) = pushParam b (doApply typ0 a) doApply typ0 (ConT tname) = qReify tname >>= doInfo typ0@@ -138,7 +138,7 @@                                  , _fieldName = Just fname                                  , _fieldType = subst ftype' } in              doField typ0 subst fld) (zip [1..] vsts)-doCon typ0 tname subst cct cpos con@(NormalC cname sts) =+doCon typ0 tname subst cct cpos (NormalC cname sts) =   mapM_ (\(i, (_, ftype)) ->              expandType ftype >>= \ftype' ->              let fld = FieldInfo { _typeName = tname

@@ -1,5 +1,5 @@ name:               th-typegraph-version:            1.0+version:            1.0.2 cabal-version:      >= 1.10 build-type:         Simple license:            BSD3