th-orphans 0.8.1 → 0.8.2
raw patch · 3 files changed
+110/−127 lines, 3 filesdep +th-reify-manydep ~basedep ~template-haskelldep ~th-lift
Dependencies added: th-reify-many
Dependency ranges changed: base, template-haskell, th-lift
Files
- src/Language/Haskell/TH/Instances.hs +34/−118
- src/Language/Haskell/TH/Instances/Internal.hs +69/−0
- th-orphans.cabal +7/−9
src/Language/Haskell/TH/Instances.hs view
@@ -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 <mgsloan at gmail>- 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 <mgsloan at gmail>+-- 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)
+ src/Language/Haskell/TH/Instances/Internal.hs view
@@ -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])
th-orphans.cabal view
@@ -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-