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 @@ -1,92 +1,56 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving, DeriveGeneric, TypeSynonymInstances, TemplateHaskell #-} - -{- | - Module : Language.Haskell.TH.Instances.Lift - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Michael Sloan - Stability : experimental - Portability : portable (template-haskell) +{-# OPTIONS_GHC -fno-warn-orphans #-} - Provides Ord and Lift instances for the TH datatypes. Also provides - Show / Eq for Loc, and Ppr for Loc / Lit. --} +-- | +-- Module : Language.Haskell.TH.Instances.Lift +-- Copyright : (c) Matt Morrow 2008 +-- License : BSD3 +-- Maintainer : Michael Sloan +-- Stability : experimental +-- Portability : portable (template-haskell) +-- +-- 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'. module Language.Haskell.TH.Instances () where -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Ppr +import GHC.Real (Ratio) +import GHC.Word (Word8) +import Language.Haskell.TH +import Language.Haskell.TH.Instances.Internal import Language.Haskell.TH.Lift (deriveLiftMany) -import GHC.Word ( Word8 ) +import Language.Haskell.TH.Ppr +import Language.Haskell.TH.ReifyMany +import Language.Haskell.TH.Syntax -- Orphan Show instances -deriving instance Show Loc +deriving instance Show Loc -- Orphan Eq instances + deriving instance Eq Loc deriving instance Eq Info - +#if MIN_VERSION_template_haskell(2,5,0) && !(MIN_VERSION_template_haskell(2,7,0)) +deriving instance Eq ClassInstance +#endif -- Orphan Ord instances + instance Ord FixityDirection where (<=) InfixL _ = True (<=) _ InfixR = True (<=) InfixN InfixN = True (<=) _ _ = False -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 - -#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 - -#if MIN_VERSION_template_haskell(2,9,0) -deriving instance Ord AnnTarget -deriving instance Ord Role -deriving instance Ord TySynEqn -#endif +$(reifyManyWithoutInstances ''Ord [''Info] (`notElem` [''Ratio]) >>= + mapM deriveOrd) -- Orphan Ppr instances + -- TODO: make this better instance Ppr Loc where ppr = showtextl . show @@ -95,58 +59,10 @@ ppr l = ppr (LitE l) -- Orphan Lift instances (for when your TH generates TH!) + -- This follows the pattern of the Lift instances for Int / Integer. instance Lift Word8 where lift w = [e| fromIntegral $(lift (fromIntegral w :: Int)) |] -$(deriveLiftMany [ ''Body - , ''Callconv - , ''Clause - , ''Con - , ''Dec - , ''Exp - , ''Fixity - , ''FixityDirection - , ''Foreign - , ''FunDep - , ''Guard - , ''Info - , ''Lit - , ''Match - , ''Pat - , ''Range - , ''Safety - , ''Stmt - , ''Strict - , ''Type - -#if MIN_VERSION_template_haskell(2,4,0) - , ''FamFlavour - , ''Pragma - , ''Pred - , ''TyVarBndr -#endif - -#if MIN_VERSION_template_haskell(2,5,0) && !(MIN_VERSION_template_haskell(2,7,0)) - , ''ClassInstance -#endif - -#if MIN_VERSION_template_haskell(2,4,0) && !(MIN_VERSION_template_haskell(2,8,0)) - , ''InlineSpec - , ''Kind -#endif - -#if MIN_VERSION_template_haskell(2,8,0) - , ''Inline - , ''Phases - , ''RuleBndr - , ''RuleMatch - , ''TyLit -#endif - -#if MIN_VERSION_template_haskell(2,9,0) - , ''AnnTarget - , ''Role - , ''TySynEqn -#endif - ]) +$(reifyManyWithoutInstances ''Lift [''Info] (const True) >>= + deriveLiftMany) diff --git a/src/Language/Haskell/TH/Instances/Internal.hs b/src/Language/Haskell/TH/Instances/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Instances/Internal.hs @@ -0,0 +1,69 @@ +{-# 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/th-orphans.cabal b/th-orphans.cabal --- a/th-orphans.cabal +++ b/th-orphans.cabal @@ -1,5 +1,5 @@ name: th-orphans -version: 0.8.1 +version: 0.8.2 cabal-version: >= 1.6 build-type: Simple license: BSD3 @@ -19,18 +19,16 @@ the version number started. library - build-depends: base >= 4.2 && < 4.8, - th-lift >= 0.5 && <0.7 - - if impl(ghc >= 7.4) - Build-depends: template-haskell >= 2.7 && < 2.10 - else - Build-depends: template-haskell >= 2.4 && < 2.7 + 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 + other-modules: Language.Haskell.TH.Instances.Internal source-repository head type: git location: git://github.com/mgsloan/th-orphans.git -