diff --git a/src/Language/Haskell/TH/Instances.hs b/src/Language/Haskell/TH/Instances.hs --- a/src/Language/Haskell/TH/Instances.hs +++ b/src/Language/Haskell/TH/Instances.hs @@ -15,11 +15,14 @@ -- Provides 'Ord' and 'Lift' instances for the datatypes in -- "Language.Haskell.TH". Also provides 'Show' and 'Eq' for 'Loc', as -- well as 'Ppr' for 'Loc' and 'Lit'. +-- +-- Note that the 'Ord' instances are not guaranteed to produce +-- consistent results across template-haskell / GHC versions, as they +-- have different data types, with different constructor orders. module Language.Haskell.TH.Instances () where import GHC.Real (Ratio) import Language.Haskell.TH -import Language.Haskell.TH.Instances.Internal import Language.Haskell.TH.Lift (deriveLiftMany) import Language.Haskell.TH.ReifyMany import Language.Haskell.TH.Syntax @@ -53,12 +56,66 @@ lift w = [e| fromIntegral $(lift (fromIntegral w :: Int)) |] #endif +$(reifyManyWithoutInstances ''Lift [''Info, ''Loc] (const True) >>= + deriveLiftMany) + +-- Ideally, it'd be possible to use reifyManyWithoutInstances for +-- these Ord instances, but TH can't output deriving instances (and +-- even if this is added for later versions, we need to support many +-- ghc / th versions). We can't generate Ord instances from TH due to +-- some undiagnosed funkiness: +-- https://github.com/mgsloan/th-orphans/issues/14 + +-- GHC 7.10 comes with Ord instances for TH datatypes. +#if !MIN_VERSION_template_haskell(2,10,0) +deriving instance Ord Info +deriving instance Ord Fixity +deriving instance Ord Exp +deriving instance Ord Dec +deriving instance Ord Stmt +deriving instance Ord Type +deriving instance Ord Foreign +deriving instance Ord FunDep +deriving instance Ord Con +deriving instance Ord Body +deriving instance Ord Clause +deriving instance Ord Strict +deriving instance Ord Safety +deriving instance Ord Callconv +deriving instance Ord Guard +deriving instance Ord Range +deriving instance Ord Match +deriving instance Ord Pat +deriving instance Ord Lit + +#if MIN_VERSION_template_haskell(2,4,0) +deriving instance Ord FamFlavour +deriving instance Ord Pragma +deriving instance Ord Pred +deriving instance Ord TyVarBndr +#endif + +#if MIN_VERSION_template_haskell(2,4,0) && !(MIN_VERSION_template_haskell(2,8,0)) +deriving instance Ord InlineSpec +deriving instance Ord Kind +#endif + #if MIN_VERSION_template_haskell(2,5,0) && !(MIN_VERSION_template_haskell(2,7,0)) deriving instance Eq ClassInstance +deriving instance Ord ClassInstance #endif -$(reifyManyWithoutInstances ''Ord [''Info] (`notElem` [''Ratio]) >>= - mapM deriveOrd) +#if MIN_VERSION_template_haskell(2,8,0) +deriving instance Ord Inline +deriving instance Ord Phases +deriving instance Ord RuleBndr +deriving instance Ord RuleMatch +deriving instance Ord TyLit +#endif -$(reifyManyWithoutInstances ''Lift [''Info, ''Loc] (const True) >>= - deriveLiftMany) +#if MIN_VERSION_template_haskell(2,9,0) +deriving instance Ord AnnTarget +deriving instance Ord Role +deriving instance Ord TySynEqn +#endif +#endif diff --git a/src/Language/Haskell/TH/Instances/Internal.hs b/src/Language/Haskell/TH/Instances/Internal.hs deleted file mode 100644 --- a/src/Language/Haskell/TH/Instances/Internal.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Language.Haskell.TH.Instances.Internal where - -import Language.Haskell.TH - --- Overall structure taken from --- https://hackage.haskell.org/package/derive-2.5.18/docs/src/Data-Derive-Ord.html - -deriveOrd :: Name -> Q Dec -deriveOrd n = do - TyConI (DataD _ _ _ cons _) <- reify n - na <- newName "a" - nb <- newName "b" - ncheck <- newName "check" - nthen <- newName "_then" - ntag <- newName "_tag" - nx <- newName "x" - ny <- newName "y" - checkClauses <- flip mapM cons $ \con -> do - (pat1, names1) <- conToPat con - (pat2, names2) <- conToPat con - return $ Clause [pat1, pat2] - (NormalB $ - foldr (\(n1, n2) -> - AppE (AppE (VarE nthen) - (AppE (AppE (VarE 'compare) - (VarE n1)) - (VarE n2)))) - (ConE 'EQ) - (zip names1 names2)) - [] - let lastCheckClause = - if length cons <= 1 - then [] - else [Clause [VarP nx, VarP ny] - (NormalB (AppE (AppE (VarE 'compare) (VarE nx)) (VarE ny))) - []] - tagClauses <- flip mapM (zip [0..] cons) $ \(ix, con) -> do - (pat, _) <- conToPat con - return $ Clause [pat] - (NormalB (SigE (LitE (IntegerL ix)) - (ConT ''Int))) - [] - return $ InstanceD [] - (AppT (ConT ''Ord) (ConT n)) - [FunD 'compare [Clause - [VarP na, VarP nb] - (NormalB (AppE (AppE (VarE ncheck) - (VarE na)) - (VarE nb))) - [ FunD ncheck (checkClauses ++ lastCheckClause) - , FunD nthen - [ Clause [ConP 'EQ [], VarP nx] (NormalB (VarE nx)) [] - , Clause [VarP nx, WildP] (NormalB (VarE nx)) [] - ] - , FunD ntag tagClauses - ]]] - -conToPat :: Con -> Q (Pat, [Name]) -conToPat (RecC n fs) = conToPat (NormalC n (map (\(_, s, t) -> (s, t)) fs)) -conToPat (ForallC _ _ con) = conToPat con -conToPat (NormalC n tys) = do - names <- mapM (\_ -> newName "_x") tys - return (ConP n (map VarP names), names) -conToPat (InfixC _ n _) = do - ln <- newName "_l" - rn <- newName "_r" - return (InfixP (VarP ln) n (VarP rn), [ln, rn]) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Language.Haskell.TH +import Language.Haskell.TH.Instances +import System.Timeout +import Test.Hspec + +main :: IO () +main = hspec $ do + -- See https://github.com/mgsloan/th-orphans/issues/13 + it "Doesn't infinite loop when comparing types" $ do + -- This can either yield LT or GT because different TH + -- versions define the constructors in different orders. + result <- timeout (1000 * 100) $ + compare (AppT (ConT ''Maybe) (ConT ''Int)) (ConT ''Char) + `shouldSatisfy` (/= EQ) + result `shouldBe` Just () + -- See https://github.com/mgsloan/th-orphans/issues/14 + it "Compares types correctly" $ + compare (AppT (ConT ''Maybe) (ConT ''Int)) (AppT (ConT ''Maybe) (ConT ''Char)) + `shouldBe` GT diff --git a/th-orphans.cabal b/th-orphans.cabal --- a/th-orphans.cabal +++ b/th-orphans.cabal @@ -1,6 +1,6 @@ name: th-orphans -version: 0.9.0 -cabal-version: >= 1.6 +version: 0.9.1 +cabal-version: >= 1.10 build-type: Simple license: BSD3 license-file: LICENSE @@ -10,8 +10,7 @@ maintainer: Michael Sloan bug-reports: https://github.com/mgsloan/th-orphans/issues stability: experimental -tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, - GHC == 7.6.1, GHC == 7.8 +tested-with: GHC == 7.4.2, GHC == 7.6.1, GHC == 7.8 synopsis: Orphan instances for TH datatypes description: Orphan instances for TH datatypes. In particular, instances for Ord and Lift, as well as a few missing Show / Eq. These @@ -19,15 +18,25 @@ the version number started. library - build-depends: base >= 4.2 && < 5, - template-haskell, - th-lift >= 0.5, - th-reify-many >= 0.1 && < 0.2 + build-depends: base >= 4.2 && < 5, + template-haskell, + th-lift >= 0.5, + th-reify-many >= 0.1 && < 0.2 + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: Language.Haskell.TH.Instances + default-language: Haskell2010 - hs-source-dirs: src - ghc-options: -Wall - exposed-modules: Language.Haskell.TH.Instances - other-modules: Language.Haskell.TH.Instances.Internal + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base, + th-orphans, + hspec, + template-haskell + default-language: Haskell2010 source-repository head type: git