diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -62,9 +62,9 @@ instance Binary a_af4Y => Binary (Company a_af4Y) ``` ## 3. Usage with Template Haskell -For generating instances with a template Haskell function, `derivingTH`, `derivingTHs` and `derivingTHss` can be used: +For generating instances with a template Haskell function, `deriving_th`, `deriving_ths` and `deriving_thss` can be used: ```haskell -derivingTHs +deriving_ths [(''ToJSON, deriveToJSON defaultOptions), (''FromJSON, deriveFromJSON defaultOptions)] ''Company diff --git a/derive-topdown.cabal b/derive-topdown.cabal --- a/derive-topdown.cabal +++ b/derive-topdown.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: derive-topdown -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Derive type class instances description: This package will make it easier to derive class instance for complex composited data types by using Template Haskell. category: Development @@ -30,11 +30,13 @@ library exposed-modules: Data.Derive.Superclass + Data.Derive.TopDown.Breaks Data.Derive.TopDown.IsInstance Data.Derive.TopDown.Instance Data.Derive.TopDown.CxtGen Data.Derive.TopDown.Standalone Data.Derive.TopDown.TH + Data.Derive.TopDown.Types Data.Derive.TopDown other-modules: Data.Derive.TopDown.Lib @@ -42,7 +44,7 @@ src default-extensions: TemplateHaskell , StandaloneDeriving , CPP - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Wmissing-home-modules -Wmissing-export-lists build-depends: base >=4.8 && <5 , containers @@ -62,6 +64,8 @@ Arity Derive Generic + GhcAst + GhcTest Instance Template Types @@ -69,13 +73,15 @@ Paths_derive_topdown hs-source-dirs: test - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Wmissing-home-modules -Wmissing-export-lists build-depends: HUnit , base >=4.8 && <5 , binary + , bytestring , containers , derive-topdown + , ghc , haskell-src , mtl , primitive diff --git a/src/Data/Derive/Superclass.hs b/src/Data/Derive/Superclass.hs --- a/src/Data/Derive/Superclass.hs +++ b/src/Data/Derive/Superclass.hs @@ -23,6 +23,7 @@ import Data.Derive.TopDown.CxtGen import Data.Derive.TopDown.IsInstance import Data.Derive.TopDown.Lib +import Data.Derive.TopDown.Types import Data.List ( foldl1' , nub ) diff --git a/src/Data/Derive/TopDown.hs b/src/Data/Derive/TopDown.hs --- a/src/Data/Derive/TopDown.hs +++ b/src/Data/Derive/TopDown.hs @@ -15,8 +15,6 @@ , module Data.Derive.TopDown.Instance , module Data.Derive.TopDown.TH , module Data.Derive.TopDown.CxtGen - , char, int, int8, int16, int32, int64, word, word8, word16, word32, word64 - , primitives, state, realWorld #if __GLASGOW_HASKELL__ >= 802 , stock, anyclass, newtype_ , DerivStrategy(StockStrategy, AnyclassStrategy, NewtypeStrategy) @@ -35,6 +33,7 @@ #if __GLASGOW_HASKELL__ >= 802 {-| The name @sock@ and @anyclass@ are still allowed to be used as functions or arguments. + See -} stock, anyclass, newtype_ :: DerivStrategy @@ -42,29 +41,3 @@ anyclass = AnyclassStrategy newtype_ = NewtypeStrategy #endif - --- | Primitive types with hashes that may cause to stop the generation process -char, int, int8, int16, int32, int64, word, word8, word16, word32, word64 :: Name -char = Name (mkOccName "Char#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) -int = Name (mkOccName "Int#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) -int8 = Name (mkOccName "Int8#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) -int16 = Name (mkOccName "Int16#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) -int32 = Name (mkOccName "Int32#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) -int64 = Name (mkOccName "Int64#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) -word = Name (mkOccName "Word#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) -word8 = Name (mkOccName "Word8#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) -word16 = Name (mkOccName "Word16#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) -word32 = Name (mkOccName "Word32#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) -word64 = Name (mkOccName "Word64#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) - --- | list of @Name@: @[char, int, int8, int16, int32, int64, word, word8, word16, word32, word64]@ -primitives :: [Name] -primitives = [char, int, int8, int16, int32, int64, word, word8, word16, word32, word64] - --- | @GHC.Prim.State#@ type -state :: Name -state = Name (mkOccName "State#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) - --- | @GHC.Prim.RealWorld#@ type -realWorld :: Name -realWorld = Name (mkOccName "RealWorld#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) diff --git a/src/Data/Derive/TopDown/Breaks.hs b/src/Data/Derive/TopDown/Breaks.hs new file mode 100644 --- /dev/null +++ b/src/Data/Derive/TopDown/Breaks.hs @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Derive.TopDown.Break +-- Copyright : (c) Song Zhang +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : haskell.zhang.song `at` hotmail.com +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- + +module Data.Derive.TopDown.Breaks ( + char, int, int8, int16, int32, int64, word, word8, + word16, word32, word64, primitives, state, realWorld +) +where + +import Language.Haskell.TH.Syntax +-- | This module contains type names that might break the instance generations +-- | New versions of derive-topdown may add more types, so you should write +-- | import list + +-- | @Char#@ type +char :: Name +char = Name (mkOccName "Char#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) +-- | @Int#@ type +int :: Name +int = Name (mkOccName "Int#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) +-- | @Int8#@ type +int8 :: Name +int8 = Name (mkOccName "Int8#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) +-- | @Int16#@ type +int16 :: Name +int16 = Name (mkOccName "Int16#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) +-- | @Int32#@ type +int32 :: Name +int32 = Name (mkOccName "Int32#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) +-- | @Int64#@ type +int64 :: Name +int64 = Name (mkOccName "Int64#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) +-- | @Word#@ type +word :: Name +word = Name (mkOccName "Word#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) +-- | @Word8#@ type +word8 :: Name +word8 = Name (mkOccName "Word8#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) +-- | @Word16#@ type +word16 :: Name +word16 = Name (mkOccName "Word16#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) +-- | @Word32#@ type +word32 :: Name +word32 = Name (mkOccName "Word32#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) +-- | @Word64#@ type +word64 :: Name +word64 = Name (mkOccName "Word64#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) + +-- | list of @Name@: @[char, int, int8, int16, int32, int64, word, word8, word16, word32, word64]@ +primitives :: [Name] +primitives = [char, int, int8, int16, int32, int64, word, word8, word16, word32, word64] + +-- | @GHC.Prim.State#@ type +state :: Name +state = Name (mkOccName "State#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) + +-- | @GHC.Prim.RealWorld#@ type +realWorld :: Name +realWorld = Name (mkOccName "RealWorld#") (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) diff --git a/src/Data/Derive/TopDown/CxtGen.hs b/src/Data/Derive/TopDown/CxtGen.hs --- a/src/Data/Derive/TopDown/CxtGen.hs +++ b/src/Data/Derive/TopDown/CxtGen.hs @@ -9,10 +9,12 @@ -- Portability : non-portable -- ----------------------------------------------------------------------------- + module Data.Derive.TopDown.CxtGen ( genInferredContext , genHoleContext , genAllFieldsContext + , ContextGenerator ) where {- @@ -35,6 +37,7 @@ import Control.Monad.State import qualified Control.Monad.Trans as T import Data.Derive.TopDown.Lib +import Data.Derive.TopDown.Types import qualified Data.List as L import qualified Data.Map as M import Data.Map ( (!) diff --git a/src/Data/Derive/TopDown/Instance.hs b/src/Data/Derive/TopDown/Instance.hs --- a/src/Data/Derive/TopDown/Instance.hs +++ b/src/Data/Derive/TopDown/Instance.hs @@ -23,6 +23,7 @@ import Data.Derive.TopDown.CxtGen ( genInferredContext ) import Data.Derive.TopDown.IsInstance import Data.Derive.TopDown.Lib +import Data.Derive.TopDown.Types import Data.List ( foldl1' ) import Language.Haskell.TH @@ -31,7 +32,7 @@ -> TypeName -> [TypeName] -- ^ a list of types that breaks the generation process -> Maybe Overlap - -> ContextGenderator -- ^ a context generator + -> ContextGenerator -- ^ a context generator -> StateT [Type] Q [Dec] gen_instance_decl cn tn breaks mo cg = do (tvbs, cons) <- lift $ getTyVarCons tn @@ -100,6 +101,6 @@ -> TypeName -> [TypeName] -- ^ a list of types that breaks the generation process -> Maybe Overlap - -> ContextGenderator -- ^ a context generator + -> ContextGenerator -- ^ a context generator -> Q [Dec] instance_with cn tn bs mo cg = evalStateT (gen_instance_decl cn tn bs mo cg) [] diff --git a/src/Data/Derive/TopDown/IsInstance.hs b/src/Data/Derive/TopDown/IsInstance.hs --- a/src/Data/Derive/TopDown/IsInstance.hs +++ b/src/Data/Derive/TopDown/IsInstance.hs @@ -14,7 +14,7 @@ ( isInstance' ) where -import Data.Derive.TopDown.Lib +import Data.Derive.TopDown.Types import Data.Generics import GHC.Exts {- @@ -59,10 +59,6 @@ remove_explicit_forall_trans = everywhere (mkT remove_explicit_forall) isInstance' :: ClassName -> [Type] -> Q Bool -isInstance' cls tys = if cls == ''Typeable - -- After GHC 7.10, GHC will generate Typeable - -- instance for all types, so this could be fine. - then return True - else +isInstance' cls tys = let trans = remove_explicit_forall_trans . replace_poly_type_trans - in isInstance cls (map trans tys) + in isInstance cls (map trans tys) diff --git a/src/Data/Derive/TopDown/Lib.hs b/src/Data/Derive/TopDown/Lib.hs --- a/src/Data/Derive/TopDown/Lib.hs +++ b/src/Data/Derive/TopDown/Lib.hs @@ -32,16 +32,12 @@ import Control.Monad.Trans import Control.Applicative import Control.Monad +import Data.Derive.TopDown.Types import Language.Haskell.TH.Datatype ( ConstructorInfo(..), DatatypeInfo(..), reifyDatatype ) - -type ClassName = Name -type TypeName = Name - -type ContextGenderator = ClassName -> TypeName -> Q Cxt noWarnExpandSynsWith :: Type -> Q Type noWarnExpandSynsWith = expandSynsWith noWarnTypeFamilies diff --git a/src/Data/Derive/TopDown/Standalone.hs b/src/Data/Derive/TopDown/Standalone.hs --- a/src/Data/Derive/TopDown/Standalone.hs +++ b/src/Data/Derive/TopDown/Standalone.hs @@ -34,6 +34,7 @@ import Control.Monad.Trans import Control.Monad.State import Data.Derive.TopDown.IsInstance +import Data.Derive.TopDown.Types import Data.List (foldl1') import Data.Primitive.Types import GHC.Generics @@ -47,11 +48,11 @@ (Data, Just NewtypeStrategy) -> return Nothing _ -> return st -gen_standalone_deriving_decl :: ClassName - -> TypeName +gen_standalone_deriving_decl :: ClassName + -> TypeName -> Maybe DerivStrategy -> [TypeName] -- ^ a list of types that breaks the generation process - -> ContextGenderator -- ^ a context generator + -> ContextGenerator -- ^ a context generator -> StateT [Type] Q [Dec] gen_standalone_deriving_decl cn tn st breaks cg = do (tvbs, cons) <- lift $ getTyVarCons tn @@ -103,9 +104,12 @@ {- | This is particularly useful with 'Generic' class. For the types like 'Int', 'Char','Ratio' or other types which are not 'Generic', there must be a way to stop the generation process on those types. + However, the deriving topdown function will only stop generating 'Generic' instances on primitive types and 'Integer' by default, so you do not need to break on them manually. + Another circumtances might be deriving for 'Typeable' class. Since there is a bug in GHC, isInstance function in TH library is not working on 'Typeable', you can manually give the types which are already instances of 'Typeable' to stop the generation process. -For others cases, there no need to use this function, bacause for a data type @A@ which is composited by another type, when you manually write an instance declaration for @A@, the process will stop on @A@ automatically since it is already an instance of the type class. + +For others cases, there is no need to use this function, bacause for a data type @A@ which is composited by another type, when you manually write an instance declaration for @A@, the process will stop on @A@ automatically since it is already an instance of the type class. -} deriving_with_breaks :: Name -- ^ class name -> Name -- ^ type name @@ -146,21 +150,25 @@ strategy_derivingss st cns tns = fmap concat $ (mapM (\x -> strategy_derivings st cns x) tns) #endif -{-| Context generator ca be the following 3 - 1. genHoleContext: It requires PartialTypeSignatures to make the context of deriving +{-| Context generator be the following 3 functions + + 1. @genHoleContext@: It requires PartialTypeSignatures to make the context of deriving context a `hole' e.g. @_ => Cls (D a b)@. This case cannot handle type family since GHC cannot handle it - 2. genInferredContext: It will try to infer the context including cases with type families. - 3. genAllFieldsContext: It will put all fields into the context. It may generate like the followings + + 2. @genInferredContext@: It will try to infer the context including cases with type families. + + 3. @genAllFieldsContext@: It will put all fields into the context. It may generate like the followings + @ data List a = Nil | Cons a (List a) deriving instance (Show a, Show (List a)) => Show (List a) @ -} -deriving_with :: ClassName - -> TypeName +deriving_with :: ClassName + -> TypeName -> Maybe DerivStrategy -- ^ deriving strategy -> [TypeName] -- ^ a list of types that breaks the generation process - -> ContextGenderator -- ^ a context generator, @genInferredContext@, @genHoleContext@ or @genAllFieldsContext@ + -> ContextGenerator -- ^ a context generator, @genInferredContext@, @genHoleContext@ or @genAllFieldsContext@ -> Q [Dec] deriving_with cn tn st bs cg = evalStateT (gen_standalone_deriving_decl cn tn st bs cg) [] diff --git a/src/Data/Derive/TopDown/TH.hs b/src/Data/Derive/TopDown/TH.hs --- a/src/Data/Derive/TopDown/TH.hs +++ b/src/Data/Derive/TopDown/TH.hs @@ -21,6 +21,7 @@ import Control.Monad.State import Data.Derive.TopDown.IsInstance ( isInstance' ) import Data.Derive.TopDown.Lib +import Data.Derive.TopDown.Types import Data.List ( foldl1' ) import Language.Haskell.TH @@ -53,7 +54,7 @@ return $ concat decls ++ decl deriving_th - :: (Name, Name -> Q [Dec]) -- ^ class name and corresponding isntance generation function + :: (Name, Name -> Q [Dec]) -- ^ class name and corresponding instance generation function -> Name -- ^ type name -> Q [Dec] deriving_th cd tname = evalStateT (genTH cd tname []) [] diff --git a/src/Data/Derive/TopDown/Types.hs b/src/Data/Derive/TopDown/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Derive/TopDown/Types.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Derive.TopDown.CxtGen +-- Copyright : (c) Song Zhang +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : haskell.zhang.song `at` hotmail.com +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- + +module Data.Derive.TopDown.Types ( + ClassName + , TypeName + , ContextGenerator) +where + +import Language.Haskell.TH + +type ClassName = Name +type TypeName = Name +type ContextGenerator = ClassName -> TypeName -> Q Cxt diff --git a/test/Derive.hs b/test/Derive.hs --- a/test/Derive.hs +++ b/test/Derive.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE TemplateHaskell, StandaloneDeriving #-} - +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PackageImports #-} module Derive where import Control.Monad.IO.Class import Data.Derive.TopDown.IsInstance -import Language.Haskell.Syntax import Language.Haskell.TH hiding ( Exp ) import Test.HUnit import Types import Utils +import qualified "haskell-src" Language.Haskell.Syntax as H eqPerson = TestCase (assertEqual "Person is instance of Eq" @@ -179,11 +179,11 @@ ordHsModule = TestCase (assertEqual "HsModule is instance of Ord" True - $((qBoolToExp $ isInstance' ''Ord [apps [ConT ''HsModule]])) + $((qBoolToExp $ isInstance' ''Ord [apps [ConT ''H.HsModule]])) ) ordHsDecl = TestCase (assertEqual "HsModule is instance of Ord" True - $((qBoolToExp $ isInstance' ''Ord [apps [ConT ''HsDecl]])) + $((qBoolToExp $ isInstance' ''Ord [apps [ConT ''H.HsDecl]])) ) diff --git a/test/GhcAst.hs b/test/GhcAst.hs new file mode 100644 --- /dev/null +++ b/test/GhcAst.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} + +module GhcAst where +import qualified Data.Maybe as Maybe +import qualified "ghc" Language.Haskell.Syntax as G +import Data.Derive.TopDown +#if __GLASGOW_HASKELL__ >= 906 +import Language.Haskell.Syntax.Module.Name +import Language.Haskell.Syntax.ImpExp +import GHC.Types.SrcLoc +import GHC.Hs.Doc +import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Type +import GHC.Types.Var +import Language.Haskell.Syntax.Concrete +import GHC.Data.FastString +import Language.Haskell.Syntax.Expr +import GHC.Types.Name.Reader +import GHC.Unit.Types +import GHC.Types.Name +import GHC.Core.TyCo.Rep +import qualified GHC.Core.TyCon as GCT +import GHC.Types.Unique +import Language.Haskell.Syntax.Basic +import GHC.Types.ForeignCall +import GHC.Types.SourceText +import GHC.Types.Basic +import GHC.Real +import GHC.Core.Coercion.Axiom +import GHC.Arr +import GHC.Data.Pair +import GHC.IORef +import GHC.Data.BooleanFormula +import GHC.Parser.Annotation +import GHC.Data.Strict +import Language.Haskell.Syntax.Lit +import Language.Haskell.Syntax.Binds +import Language.Haskell.Syntax.Pat +import GHC.Types.Fixity +import GHC.Data.Bag +import GHC.Types.Unique.DSet +import GHC.STRef +import GHC.Generics +import Data.ByteString.Short.Internal +import GHC.ForeignPtr +import Data.ByteString.Internal + + +$(deriving_with ''Generic ''G.HsModule Maybe.Nothing [ + ''ShortByteString, + ''ForeignPtr, + ''Array, + ''Var, + ''GCT.TyCon, + ''IORef, + ''STRef, + ''Bag, + ''STRef, + ''FastZString, + ''RealSrcSpan, + ''ByteString, + ''Name, + ''UniqDSet, + ''Unique, + ''OccName] genInferredContext) +#endif diff --git a/test/GhcTest.hs b/test/GhcTest.hs new file mode 100644 --- /dev/null +++ b/test/GhcTest.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE CPP #-} +module GhcTest where + +import GhcAst +import Data.Derive.TopDown.IsInstance +import GHC.Generics +import qualified "ghc" Language.Haskell.Syntax as G +import Utils +import Language.Haskell.TH +import Test.HUnit +import Types + +#if __GLASGOW_HASKELL__ >= 906 +genericGhcHsModule = TestCase + (assertEqual "GhcHsModule is instance of Generic" + True + $((qBoolToExp $ isInstance' ''Generic [apps [(ConT ''G.HsModule), (VarT (mkName "a"))]])) + ) +#else +genericGhcHsModule = TestCase (assertEqual " " True True) +#endif diff --git a/test/Instance.hs b/test/Instance.hs --- a/test/Instance.hs +++ b/test/Instance.hs @@ -1,13 +1,14 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PackageImports #-} module Instance where import Data.Binary import Data.Derive.TopDown.IsInstance -import Language.Haskell.Syntax import Language.Haskell.TH.Syntax import Test.HUnit import Types import Utils +import qualified "haskell-src" Language.Haskell.Syntax as H binaryCompany = TestCase (assertEqual "Company is instance of Binary" @@ -94,6 +95,6 @@ binaryHsModule = TestCase (assertEqual "HsModule is instance of Binary" True - $((qBoolToExp $ isInstance' ''Binary [ConT ''HsModule])) + $((qBoolToExp $ isInstance' ''Binary [ConT ''H.HsModule])) ) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE CPP #-} module Main where import Control.Monad @@ -6,6 +8,7 @@ import Instance import Template import Test.HUnit +import GhcTest derive = TestList [ eqPerson @@ -113,9 +116,13 @@ , arityHsModule , arityHsDecl ] + +ghcAst = TestList [genericGhcHsModule] + main :: IO () main = do void $ runTestTT derive void $ runTestTT generic void $ runTestTT instances void $ runTestTT templates + void $ runTestTT ghcAst diff --git a/test/Template.hs b/test/Template.hs --- a/test/Template.hs +++ b/test/Template.hs @@ -1,8 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PackageImports #-} + module Template where import Arity import Data.Derive.TopDown.IsInstance -import Language.Haskell.Syntax +import qualified "haskell-src" Language.Haskell.Syntax as H import Language.Haskell.TH.Syntax hiding ( Exp ) import Test.HUnit @@ -153,12 +155,12 @@ (assertEqual "HsModule is instance of Arity" True - $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''HsModule]])) + $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''H.HsModule]])) ) arityHsDecl = TestCase (assertEqual "HsDecl is instance of Arity" True - $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''HsDecl]])) + $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''H.HsDecl]])) ) diff --git a/test/Types.hs b/test/Types.hs --- a/test/Types.hs +++ b/test/Types.hs @@ -19,7 +19,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE DeriveAnyClass #-} - +{-# LANGUAGE PackageImports #-} module Types where @@ -28,12 +28,14 @@ import Data.Binary import Data.Derive.Superclass import Data.Derive.TopDown +import Data.Derive.TopDown.Breaks import Data.Proxy import Data.Ratio import GHC.Generics hiding ( C , D ) -import Language.Haskell.Syntax +import qualified "haskell-src" Language.Haskell.Syntax as H + -- types for testing -- ^ simple cases @@ -282,7 +284,8 @@ $(deriving_th (''TypeArity, makeTypeArity) ''F32) -- deriving GHC syntax tree in haskell-src -$(deriving_ ''Ord ''HsModule) -$(deriving_with ''Generic ''HsModule Nothing [''Ratio] genInferredContext) -$(instance_ ''Binary ''HsModule) -$(deriving_th (''TypeArity, makeTypeArity) ''HsModule) +$(deriving_ ''Ord ''H.HsModule) +$(deriving_with ''Generic ''H.HsModule Nothing [''Ratio] genInferredContext) +$(instance_ ''Binary ''H.HsModule) +$(deriving_th (''TypeArity, makeTypeArity) ''H.HsModule) +