haskell-src-meta 0.5.1.2 → 0.6
raw patch · 7 files changed
+203/−453 lines, 7 filesdep +th-orphansdep −th-liftdep ~base
Dependencies added: th-orphans
Dependencies removed: th-lift
Dependency ranges changed: base
Files
- ChangeLog +74/−0
- README +0/−63
- haskell-src-meta.cabal +5/−5
- src/Language/Haskell/Meta.hs +1/−1
- src/Language/Haskell/Meta/Syntax/Translate.hs +103/−158
- src/Language/Haskell/Meta/Utils.hs +14/−147
- src/Language/Haskell/TH/Instances/Lift.hs +6/−79
+ ChangeLog view
@@ -0,0 +1,74 @@+0.5.1.2 -> 0.6:+- Cabal category Template Haskell+- Partial support for list comprehensions+- Support for type and data families and class decs+- Split orphan instances into new package th-orphans+ - above changes courtesy of mgsloan+ - L.H.TH.Instances.Lift now deprecated+- Removed L.H.M.Utils.deriveLiftPretty, dropped th-lift dependency+- Rename L.H.M.Utils.unQ to unsafeRunQ+- instance ToName Op+- Support for unboxed tuple types and kind signatures+- Compatibility with GHC 7.6.1, bringing support for kind variables+ and infix declarations++0.5.1.1 -> 0.5.1.2:+- More sensible determination of TH version available++0.5.1 -> 0.5.1.1:+- View pattern support, thanks to Nicolas Frisby.++0.5.0.3 -> 0.5.1:+- New module Language.Haskell.Meta.Parse.Careful, written by Reiner Pope+ so that ambiguous parses can be rejected instead of quietly done wrong.++0.5.0.2 -> 0.5.0.3:+- Support for GHC 7.4, thanks to Reiner Pope+- Support for unresolved infix expressions, again thanks to Reiner Pope++0.5.0.1 -> 0.5.0.2:+- Fixed bug in translation of tuple constructors++0.5 -> 0.5.0.1:+- Added support for primitive string literals (Only in TH >= 2.5)++0.4.0.2 -> 0.5:+- Added support for instance declarations++0.4.0.1 -> 0.4.0.2:+- Compatibility with GHC 7.2++0.4 -> 0.4.0.1:+- Deprecate myDefaultParseMode and myDefaultExtensions in L.H.M.Parse++0.3 -> 0.4:+- Remove Language.Haskell.Meta.Syntax.Vars and the L.H.M.Syntax re-export module+- Remove dependency on containers+- Add support for let statements in (pattern) guards+- Add support for negative patterns+- Remove "support" for SpliceExps that didn't really make sense+- Improve many error messages where things are unimplemented or impossible++0.2 -> 0.3:+- Fixes/additions to inline pragma support (Jonas Duregard)+- Compatibility with GHC 7 and TH 2.5 - totalling three major versions!+- Move some of the quasiquoters to their own package, and stop exporting+ the rest (they are kept as examples of usage)++0.1.1 -> 0.2:+- Compatibility with GHC 6.10 and TH 2.3 (Geoffrey Mainland)+- Add support for do-blocks, pattern guards (Adam Vogt)+- Add applicative-do quasiquoter (Adam Vogt)++0.1.0 -> 0.1.1:+- Add support for inline pragmas, and improve support for type+ signatures (patch by Jonas Duregard)++0.0.6 -> 0.1.0:+- Used the th-lift library to autogenerate the instances of Lift in+ Language.Haskell.TH.Instances.Lift+- Added support for the new features of template-haskell-2.4.0.0:+ contexts, kinds, bang patterns, unboxed word literals.+- Updated use of haskell-src-exts in response to API changes.+- Added ToDecs class because some HSE Decls don't map to a single Dec.+ (patch by Jonas Duregard)
README view
@@ -9,66 +9,3 @@ I don't really view this as "my" package so if you want write access to the github repository, or you think you could do a better job as maintainer, just ask.--Major changes:--0.5.1.1 -> 0.5.1.2:-- More sensible determination of TH version available--0.5.1 -> 0.5.1.1:-- View pattern support, thanks to Nicolas Frisby.--0.5.0.3 -> 0.5.1:-- New module Language.Haskell.Meta.Parse.Careful, written by Reiner Pope- so that ambiguous parses can be rejected instead of quietly done wrong.--0.5.0.2 -> 0.5.0.3:-- Support for GHC 7.4, thanks to Reiner Pope-- Support for unresolved infix expressions, again thanks to Reiner Pope--0.5.0.1 -> 0.5.0.2:-- Fixed bug in translation of tuple constructors--0.5 -> 0.5.0.1:-- Added support for primitive string literals (Only in TH >= 2.5)--0.4.0.2 -> 0.5:-- Added support for instance declarations--0.4.0.1 -> 0.4.0.2:-- Compatibility with GHC 7.2--0.4 -> 0.4.0.1:-- Deprecate myDefaultParseMode and myDefaultExtensions in L.H.M.Parse--0.3 -> 0.4:-- Remove Language.Haskell.Meta.Syntax.Vars and the L.H.M.Syntax re-export module-- Remove dependency on containers-- Add support for let statements in (pattern) guards-- Add support for negative patterns-- Remove "support" for SpliceExps that didn't really make sense-- Improve many error messages where things are unimplemented or impossible--0.2 -> 0.3:-- Fixes/additions to inline pragma support (Jonas Duregard)-- Compatibility with GHC 7 and TH 2.5 - totalling three major versions!-- Move some of the quasiquoters to their own package, and stop exporting- the rest (they are kept as examples of usage)--0.1.1 -> 0.2:-- Compatibility with GHC 6.10 and TH 2.3 (Geoffrey Mainland)-- Add support for do-blocks, pattern guards (Adam Vogt)-- Add applicative-do quasiquoter (Adam Vogt)--0.1.0 -> 0.1.1:-- Add support for inline pragmas, and improve support for type- signatures (patch by Jonas Duregard)--0.0.6 -> 0.1.0:-- Used the th-lift library to autogenerate the instances of Lift in- Language.Haskell.TH.Instances.Lift-- Added support for the new features of template-haskell-2.4.0.0:- contexts, kinds, bang patterns, unboxed word literals.-- Updated use of haskell-src-exts in response to API changes.-- Added ToDecs class because some HSE Decls don't map to a single Dec.- (patch by Jonas Duregard)
haskell-src-meta.cabal view
@@ -1,10 +1,10 @@ name: haskell-src-meta-version: 0.5.1.2+version: 0.6 cabal-version: >= 1.6 build-type: Simple license: BSD3 license-file: LICENSE-category: Language+category: Language, Template Haskell author: Matt Morrow copyright: (c) Matt Morrow maintainer: Ben Millwood <haskell@benmachine.co.uk>@@ -15,14 +15,14 @@ description: The translation from haskell-src-exts abstract syntax to template-haskell abstract syntax isn't 100% complete yet. -extra-source-files: examples/*.hs README+extra-source-files: ChangeLog README examples/*.hs library- build-depends: base >= 4.2 && < 4.6,+ build-depends: base >= 4.2 && < 4.7, haskell-src-exts >= 1.8 && < 1.14, pretty >= 1.0 && < 1.2, syb >= 0.1 && < 0.4,- th-lift == 0.5.*+ th-orphans >= 0.5 && < 0.7 if impl(ghc >= 7.4) Build-depends: template-haskell >= 2.7 && < 2.9
src/Language/Haskell/Meta.hs view
@@ -15,4 +15,4 @@ import Language.Haskell.Meta.Parse import Language.Haskell.Meta.Syntax.Translate-import Language.Haskell.TH.Instances.Lift()+import Language.Haskell.TH.Instances()
src/Language/Haskell/Meta/Syntax/Translate.hs view
@@ -13,6 +13,7 @@ module Language.Haskell.Meta.Syntax.Translate ) where +import Data.Char (ord) import Data.Typeable import Data.List (foldl', nub, (\\)) import Language.Haskell.TH.Syntax@@ -128,7 +129,11 @@ toName (Hs.Special s) = toName s +instance ToName Hs.Op where+ toName (Hs.VarOp n) = toName n+ toName (Hs.ConOp n) = toName n + ----------------------------------------------------------------------------- -- * ToLit HsLiteral@@ -139,18 +144,22 @@ toLit (Hs.String a) = StringL a toLit (Hs.Int a) = IntegerL a toLit (Hs.Frac a) = RationalL a- toLit (Hs.PrimChar a) = CharL a -- XXX-#if MIN_VERSION_template_haskell(2,5,0)+ toLit l@Hs.PrimChar{} = noTH "toLit" l+#if MIN_VERSION_template_haskell(2,8,0)+ toLit (Hs.PrimString a) = StringPrimL (map toWord8 a)+ where+ toWord8 = fromIntegral . ord+#elif MIN_VERSION_template_haskell(2,5,0) toLit (Hs.PrimString a) = StringPrimL a-#else /* MIN_VERSION_template_haskell(2,5,0) */- toLit (Hs.PrimString a) = StringL a -- XXX-#endif /* MIN_VERSION_template_haskell(2,5,0) */+#else+ toLit l@Hs.PrimString{} = noTH "toLit" l+#endif toLit (Hs.PrimInt a) = IntPrimL a toLit (Hs.PrimFloat a) = FloatPrimL a toLit (Hs.PrimDouble a) = DoublePrimL a #if MIN_VERSION_template_haskell(2,4,0) toLit (Hs.PrimWord a) = WordPrimL a-#endif /* MIN_VERSION_template_haskell(2,4,0) */+#endif -----------------------------------------------------------------------------@@ -163,10 +172,6 @@ = VarP (toName n) toPat (Hs.PLit l) = LitP (toLit l)-{--ghci> parseHsPat "-2"-Right (HsPParen (HsPNeg (HsPLit (HsInt 2))))--} toPat (Hs.PNeg (Hs.PLit l)) = LitP $ case toLit l of IntegerL z -> IntegerL (negate z) RationalL q -> RationalL (negate q)@@ -224,20 +229,6 @@ instance ToExp Hs.Exp where-{--data HsExp- = HsVar HsQName--}--- | HsIPVar HsIPName-{-- | HsLet HsBinds HsExp- | HsDLet [HsIPBind] HsExp- | HsWith HsExp [HsIPBind]- | HsCase HsExp [HsAlt]- | HsDo [HsStmt]- -- use mfix somehow- | HsMDo [HsStmt]--} toExp (Hs.Var n) = VarE (toName n) toExp (Hs.Con n) = ConE (toName n) toExp (Hs.Lit l) = LitE (toLit l)@@ -252,10 +243,9 @@ toExp (Hs.NegApp e) = AppE (VarE 'negate) (toExp e) toExp (Hs.Lambda _ ps e) = LamE (fmap toPat ps) (toExp e) toExp (Hs.Let bs e) = LetE (hsBindsToDecs bs) (toExp e)- -- toExp (HsWith e bs toExp (Hs.If a b c) = CondE (toExp a) (toExp b) (toExp c) toExp (Hs.Do ss) = DoE (map toStmt ss)- -- toExp (HsMDo ss)+ toExp e@(Hs.MDo _) = noTH "toExp" e toExp (Hs.Tuple xs) = TupE (fmap toExp xs) toExp (Hs.List xs) = ListE (fmap toExp xs) #if MIN_VERSION_template_haskell(2,7,0)@@ -270,19 +260,10 @@ toExp (Hs.EnumFromThen e f) = ArithSeqE $ FromThenR (toExp e) (toExp f) toExp (Hs.EnumFromThenTo e f g) = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g) toExp (Hs.ExpTypeSig _ e t) = SigE (toExp e) (toType t)- -- HsListComp HsExp [HsStmt]- -- toExp (HsListComp e ss) = CompE- -- NEED: a way to go e -> Stmt-{- HsVarQuote HsQName- | HsTypQuote HsQName- | HsBracketExp HsBracket- | HsSpliceExp HsSplice-data HsBracket- = HsExpBracket HsExp- | HsPatBracket HsPat- | HsTypeBracket HsType- | HsDeclBracket [HsDecl]-data HsSplice = HsIdSplice String | HsParenSplice HsExp -}+ toExp (Hs.ListComp e ss) = CompE $ map convert ss ++ [NoBindS (toExp e)]+ where+ convert (Hs.QualStmt st) = toStmt st+ convert s = noTH "toExp ListComp" s toExp (Hs.Case e alts) = CaseE (toExp e) (map toMatch alts) toExp e = todo "toExp" e @@ -304,36 +285,6 @@ ----------------------------------------------------------------------------- -{--class ToName a where toName :: a -> Name-class ToLit a where toLit :: a -> Lit-class ToType a where toType :: a -> Type-class ToPat a where toPat :: a -> Pat-class ToExp a where toExp :: a -> Exp-class ToDec a where toDec :: a -> Dec-class ToStmt a where toStmt :: a -> Stmt-class ToLoc a where toLoc :: a -> Loc--}--{--TODO:- []--PARTIAL:- * ToExp HsExp- * ToStmt HsStmt- * ToDec HsDecl--DONE:- * ToLit HsLiteral- * ToName {..}- * ToPat HsPat- * ToLoc SrcLoc- * ToType HsType---}------------------------------------------------------------------------------- -- * ToLoc SrcLoc instance ToLoc Hs.SrcLoc where@@ -358,12 +309,28 @@ #endif /* !MIN_VERSION_template_haskell(2,4,0) */ #if MIN_VERSION_template_haskell(2,4,0)+#if MIN_VERSION_template_haskell(2,8,0)++instance ToType Hs.Kind where+ toType Hs.KindStar = StarT+ toType (Hs.KindFn k1 k2) = toType k1 .->. toType k2+ toType (Hs.KindParen kp) = toType kp+ toType k@Hs.KindBang = noTH "toKind" k+ toType (Hs.KindVar n) = VarT (toName n)+ toKind :: Hs.Kind -> Kind+toKind = toType++#else++toKind :: Hs.Kind -> Kind toKind Hs.KindStar = StarK toKind (Hs.KindFn k1 k2) = ArrowK (toKind k1) (toKind k2) toKind (Hs.KindParen kp) = toKind kp toKind k@Hs.KindBang = noTH "toKind" k toKind k@Hs.KindVar{} = noTH "toKind" k++#endif /* !MIN_VERSION_template_haskell(2,8,0) */ #endif /* !MIN_VERSION_template_haskell(2,4,0) */ #if MIN_VERSION_template_haskell(2,4,0)@@ -376,25 +343,26 @@ toTyVar (Hs.UnkindedVar n) = toName n #endif /* !MIN_VERSION_template_haskell(2,4,0) */ -{- |-TH does't handle- * unboxed tuples- * implicit params- * infix type constructors- * kind signatures--} instance ToType Hs.Type where toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t) toType (Hs.TyFun a b) = toType a .->. toType b toType (Hs.TyList t) = ListT `AppT` toType t- toType (Hs.TyTuple _ ts) = foldAppT (TupleT . length $ ts) (fmap toType ts)+ toType (Hs.TyTuple b ts) = foldAppT (tuple . length $ ts) (fmap toType ts)+ where+ tuple = case b of+ Hs.Boxed -> TupleT+#if MIN_VERSION_template_haskell(2,6,0)+ Hs.Unboxed -> UnboxedTupleT+#else+ Hs.Unboxed -> noTH "toType TyTuple" (Hs.TyTuple b ts)+#endif toType (Hs.TyApp a b) = AppT (toType a) (toType b) toType (Hs.TyVar n) = VarT (toName n) toType (Hs.TyCon qn) = ConT (toName qn) toType (Hs.TyParen t) = toType t -- XXX: need to wrap the name in parens! toType (Hs.TyInfix a o b) = AppT (AppT (ConT (toName o)) (toType a)) (toType b)- toType (Hs.TyKind t _) = toType t+ toType (Hs.TyKind t k) = SigT (toType t) (toKind k) @@ -402,11 +370,6 @@ (.->.) :: Type -> Type -> Type a .->. b = AppT (AppT ArrowT a) b -{- |-TH doesn't handle:- * implicit params--}- toCxt :: Hs.Context -> Cxt toCxt = fmap toPred where@@ -415,12 +378,12 @@ toPred (Hs.InfixA t1 n t2) = ClassP (toName n) (fmap toType [t1, t2]) toPred (Hs.EqualP t1 t2) = EqualP (toType t1) (toType t2) toPred a@Hs.IParam{} = noTH "toCxt" a-#else /* !MIN_VERSION_template_haskell(2,4,0) */+#else toPred (Hs.ClassA n ts) = foldAppT (ConT (toName n)) (fmap toType ts) toPred (Hs.InfixA t1 n t2) = foldAppT (ConT (toName n)) (fmap toType [t1, t2]) toPred a@Hs.EqualP{} = noTH "toCxt" a toPred a@Hs.IParam{} = noTH "toCxt" a-#endif /* !MIN_VERSION_template_haskell(2,4,0) */+#endif foldAppT :: Type -> [Type] -> Type foldAppT t ts = foldl' AppT t ts@@ -439,11 +402,9 @@ -- * ToDec HsDecl --- data HsBinds = HsBDecls [HsDecl] | HsIPBinds [HsIPBind] hsBindsToDecs :: Hs.Binds -> [Dec] hsBindsToDecs (Hs.BDecls ds) = fmap toDec ds hsBindsToDecs a@Hs.IPBinds{} = noTH "hsBindsToDecs" a--- data HsIPBind = HsIPBind SrcLoc HsIPName HsExp hsBangTypeToStrictType :: Hs.BangType -> (Strict, Type)@@ -451,89 +412,63 @@ hsBangTypeToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t) -{--data HsTyVarBind = HsKindedVar HsName HsKind | HsUnkindedVar HsName-data HsConDecl- = HsConDecl HsName [HsBangType]- | HsRecDecl HsName [([HsName], HsBangType)]--}-{--hsQualConDeclToCon :: HsQualConDecl -> Con-hsQualConDeclToCon (HsQualConDecl _ tvbs cxt condec) =- case condec of- HsConDecl n bangs ->- HsRecDecl n assocs ->--}---- instance ToDec Hs.Decl where toDec (Hs.TypeDecl _ n ns t) = TySynD (toName n) (fmap toTyVar ns) (toType t) - toDec a@(Hs.DataDecl _ dOrN cxt n ns qcds qns) = case dOrN of Hs.DataType -> DataD (toCxt cxt)- (toName n)- (fmap toTyVar ns)- (fmap qualConDeclToCon qcds)- (fmap (toName . fst) qns)+ (toName n)+ (fmap toTyVar ns)+ (fmap qualConDeclToCon qcds)+ (fmap (toName . fst) qns) Hs.NewType -> let qcd = case qcds of [x] -> x _ -> nonsense "toDec" ("newtype with " ++- "wrong number of constructors") dOrN+ "wrong number of constructors") a in NewtypeD (toCxt cxt) (toName n) (fmap toTyVar ns) (qualConDeclToCon qcd) (fmap (toName . fst) qns) --- data Hs.BangType--- = Hs.BangedTy Hs.Type--- | Hs.UnBangedTy Hs.Type--- | Hs.UnpackedTy Hs.Type--- data Hs.TyVarBind--- = Hs.KindedVar Hs.Name Hs.Kind | Hs.UnkindedVar Hs.Name--- data Hs.DataOrNew = Hs.DataType | Hs.NewType--- data Hs.QualConDecl--- = Hs.QualConDecl Hs.SrcLoc [Hs.TyVarBind] Hs.Context Hs.ConDecl--- data Hs.ConDecl--- = Hs.ConDecl Hs.Name [Hs.BangType]--- | Hs.RecDecl Hs.Name [([Hs.Name], Hs.BangType)]---- data Con--- = NormalC Name [StrictType]--- | RecC Name [VarStrictType]--- | InfixC StrictType Name StrictType--- | ForallC [Name] Cxt Con--- type StrictType = (Strict, Type)--- type VarStrictType = (Name, Strict, Type)-- -- This type-signature conversion is just wrong. -- Type variables need to be dealt with. /Jonas toDec a@(Hs.TypeSig _ ns t) -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class! = let xs = fmap (flip SigD (toType t) . toName) ns in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!"+ #if MIN_VERSION_template_haskell(2,4,0)+#if MIN_VERSION_template_haskell(2,8,0)++ toDec (Hs.InlineConlikeSig _ act qn) = PragmaD $+ InlineP (toName qn) Inline ConLike (transAct act)+ toDec (Hs.InlineSig _ b act qn) = PragmaD $+ InlineP (toName qn) inline FunLike (transAct act)+ where+ inline | b = Inline | otherwise = NoInline++#else+ toDec (Hs.InlineConlikeSig _ act id) = PragmaD $ InlineP (toName id) (InlineSpec True True $ transAct act) toDec (Hs.InlineSig _ b act id) = PragmaD $ InlineP (toName id) (InlineSpec b False $ transAct act)++#endif /* MIN_VERSION_template_haskell(2,8,0) */++ toDec (Hs.TypeFamDecl _ n ns k)+ = FamilyD TypeFam (toName n) (fmap toTyVar ns) (fmap toKind k)++ -- TODO: do something with context?+ toDec (Hs.DataFamDecl _ _ n ns k)+ = FamilyD DataFam (toName n) (fmap toTyVar ns) (fmap toKind k)+ #endif /* MIN_VERSION_template_haskell(2,4,0) */ -{- data HsDecl = ... | HsFunBind [HsMatch] | ...-data HsMatch = HsMatch SrcLoc HsName [HsPat] HsRhs HsBinds-data Dec = FunD Name [Clause] | ...-data Clause = Clause [Pat] Body [Dec] -} toDec a@(Hs.FunBind mtchs) = hsMatchesToFunD mtchs-{- ghci> parseExp "let x = 2 in x"-LetE [ValD (VarP x) (NormalB (LitE (IntegerL 2))) []] (VarE x)-ghci> unQ[| let x = 2 in x |]-LetE [ValD (VarP x_0) (NormalB (LitE (IntegerL 2))) []] (VarE x_0) -} toDec (Hs.PatBind _ p tM rhs bnds) = ValD ((maybe id (flip SigP . toType) tM) (toPat p))@@ -544,23 +479,32 @@ (toCxt cxt) (foldl AppT (ConT (toName qname)) (map toType ts)) (toDecs ids)- - toDec x = todo "toDec" x + toDec (Hs.ClassDecl _ cxt name ts fds decls) = ClassD+ (toCxt cxt)+ (toName name)+ (fmap toTyVar ts)+ (fmap toFunDep fds)+ (fmap classDeclToDec decls)+ where+ classDeclToDec cd = case cd of+ (Hs.ClsDecl d) -> toDec d+ x -> todo "classDecl" x+ toFunDep (Hs.FunDep ls rs) = FunDep (fmap toName ls) (fmap toName rs) --- data Hs.Decl = ... | Hs.SpliceDecl Hs.SrcLoc Hs.Splice | ...--- data Hs.Splice = Hs.IdSplice String | Hs.ParenSplice Hs.Exp+ toDec x = todo "toDec" x +#if MIN_VERSION_template_haskell(2,8,0)+transAct :: Hs.Activation -> Phases+transAct Hs.AlwaysActive = AllPhases+transAct (Hs.ActiveFrom n) = FromPhase n+transAct (Hs.ActiveUntil n) = BeforePhase n+#else transAct act = case act of Hs.AlwaysActive -> Nothing Hs.ActiveFrom n -> Just (True,n) Hs.ActiveUntil n -> Just (False,n)------+#endif qualConDeclToCon :: Hs.QualConDecl -> Con@@ -568,7 +512,6 @@ qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (fmap toTyVar ns) (toCxt cxt) (conDeclToCon cdecl)- conDeclToCon :: Hs.ConDecl -> Con conDeclToCon (Hs.ConDecl n tys) = NormalC (toName n) (fmap bangToStrictType tys)@@ -576,7 +519,6 @@ = RecC (toName n) (concatMap (uncurry bangToVarStrictTypes) lbls) - bangToVarStrictTypes :: [Hs.Name] -> Hs.BangType -> [VarStrictType] bangToVarStrictTypes ns t = let (a,b) = bangToStrictType t in fmap (\n->(toName n,a,b)) ns@@ -600,10 +542,6 @@ --- data HsRhs = HsUnGuardedRhs HsExp | HsGuardedRhs [HsGuardedRhs]--- data HsGuardedRhs = HsGuardedRhs SrcLoc [HsStmt] HsExp--- data Body = GuardedB [(Guard, Exp)] | NormalB Exp--- data Guard = NormalG Exp | PatG [Stmt] hsRhsToBody :: Hs.Rhs -> Body hsRhsToBody (Hs.UnGuardedRhs e) = NormalB (toExp e) hsRhsToBody (Hs.GuardedRhss hsgrhs) = let fromGuardedB (GuardedB a) = a@@ -642,12 +580,19 @@ -- * ToDecs HsDecl HsBinds instance ToDecs Hs.Decl where--- toDecs a@(Hs.InfixDecl _ asst i ops) = [] -- HACK--- toDecs (Hs.InlineSig _ _ _ _) = [] -- HACK toDecs a@(Hs.TypeSig _ ns t) = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns in xs +#if MIN_VERSION_template_haskell(2,8,0)+ toDecs (Hs.InfixDecl _ assoc fixity ops) =+ map (\op -> InfixD (Fixity fixity dir) (toName op)) ops+ where+ dir = case assoc of+ Hs.AssocNone -> InfixN+ Hs.AssocLeft -> InfixL+ Hs.AssocRight -> InfixR+#endif toDecs a = [toDec a]
src/Language/Haskell/Meta/Utils.hs view
@@ -8,6 +8,7 @@ module Language.Haskell.Meta.Utils where +import Data.List (findIndex) import Data.Typeable import Data.Generics hiding(Fixity) import Language.Haskell.Meta@@ -16,7 +17,6 @@ import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Language.Haskell.TH.Lib-import Language.Haskell.TH.Lift (deriveLift) import Language.Haskell.TH.Ppr import Text.PrettyPrint import Control.Monad@@ -56,20 +56,20 @@ gpretty = either (const []) prettyPrint . parseHsExp . gshow -instance Show ExpQ where show = show . cleanNames . unQ-instance Show (Q [Dec]) where show = unlines . fmap (show . cleanNames) . unQ-instance Show DecQ where show = show . cleanNames . unQ-instance Show TypeQ where show = show . cleanNames . unQ-instance Show (Q String) where show = unQ-instance Show (Q Doc) where show = show . unQ+instance Show ExpQ where show = show . cleanNames . unsafeRunQ+instance Show (Q [Dec]) where show = unlines . fmap (show . cleanNames) . unsafeRunQ+instance Show DecQ where show = show . cleanNames . unsafeRunQ+instance Show TypeQ where show = show . cleanNames . unsafeRunQ+instance Show (Q String) where show = unsafeRunQ+instance Show (Q Doc) where show = show . unsafeRunQ deriving instance Typeable1 Q deriving instance Typeable QuasiQuoter --- | @unQ = unsafePerformIO . runQ@-unQ :: Q a -> a-unQ = unsafePerformIO . runQ+-- | @unsafeRunQ = unsafePerformIO . runQ@+unsafeRunQ :: Q a -> a+unsafeRunQ = unsafePerformIO . runQ nameToRawCodeStr :: Name -> String@@ -203,17 +203,6 @@ --- | Produces pretty code suitable--- for human consumption.-deriveLiftPretty :: Name -> Q String-deriveLiftPretty n = do- decs <- deriveLift n- case (parseHsDecls . pprint . cleanNames) decs of- Left e -> fail ("deriveLiftPretty: error while prettifying code: "++e)- Right hsdecs -> return (unlines . fmap prettyPrint $ hsdecs)--- splitCon :: Con -> (Name,[Type]) splitCon c = (conName c, conTypes c) @@ -389,134 +378,12 @@ where go :: Type -> Type go (ConT n) | n == ''[] = ListT go (AppT (TupleT 1) t) = t- go (ConT n) | n == ''(,) = TupleT 2- go (ConT n) | n == ''(,,) = TupleT 3- go (ConT n) | n == ''(,,,) = TupleT 4- go (ConT n) | n == ''(,,,,) = TupleT 5- go (ConT n) | n == ''(,,,,,) = TupleT 6- go (ConT n) | n == ''(,,,,,,) = TupleT 7- go (ConT n) | n == ''(,,,,,,,) = TupleT 8- go (ConT n) | n == ''(,,,,,,,,) = TupleT 9- go (ConT n) | n == ''(,,,,,,,,,) = TupleT 10- go (ConT n) | n == ''(,,,,,,,,,,) = TupleT 11- go (ConT n) | n == ''(,,,,,,,,,,,) = TupleT 12- go (ConT n) | n == ''(,,,,,,,,,,,,) = TupleT 13- go (ConT n) | n == ''(,,,,,,,,,,,,,) = TupleT 14- go (ConT n) | n == ''(,,,,,,,,,,,,,,) = TupleT 15- go (ConT n) | n == ''(,,,,,,,,,,,,,,,) = TupleT 16- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,) = TupleT 17- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,) = TupleT 18- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,) = TupleT 19- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,) = TupleT 20- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,) = TupleT 21- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,) = TupleT 22- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,) = TupleT 23- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 24- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 25- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 26- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 27- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 28- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 29- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 30- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 31- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 32- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 33- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 34- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 35- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 36- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 37- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 38- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 39- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 40- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 41- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 42- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 43- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 44- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 45- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 46- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 47- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 48- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 49- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 50- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 51- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 52- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 53- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 54- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 55- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 56- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 57- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 58- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 59- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 60- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 61- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 62- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 63- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 64+ go (ConT n)+ | Just m <- findIndex (== n) tupleNames = TupleT (m + 2)+ where+ tupleNames = map tupleTypeName [2 .. 64] go t = t --------------------------------------------------------------------------------------------------------------------------------------------
src/Language/Haskell/TH/Instances/Lift.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE StandaloneDeriving, TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}- {- | Module : Language.Haskell.TH.Instances.Lift Copyright : (c) Matt Morrow 2008@@ -11,79 +7,10 @@ Portability : portable (template-haskell) -} -module Language.Haskell.TH.Instances.Lift () where--import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.Lift (deriveLiftMany)--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 TyVarBndr-deriving instance Ord Pred-deriving instance Ord Kind-deriving instance Ord FamFlavour-deriving instance Ord InlineSpec-deriving instance Ord Pragma-#endif /* MIN_VERSION_template_haskell(2,4,0) */--deriving instance Show Loc-deriving instance Eq Loc---- TODO: make this better-instance Ppr Loc where- ppr = showtextl . show--instance Ppr Lit where- ppr l = ppr (LitE l)--$(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- , ''InlineSpec- , ''Kind- , ''Pragma- , ''Pred- , ''TyVarBndr-#if MIN_VERSION_template_haskell(2,5,0) && !(MIN_VERSION_template_haskell(2,7,0))- , ''ClassInstance-#endif /* MIN_VERSION_template_haskell(2,5,0) && !(MIN_VERSION_template_haskell(2,7,0)) */-#endif /* MIN_VERSION_template_haskell(2,4,0) */- ])+-- | This module is exported for backwards-compatibility purposes.+-- All it does is re-export the instances defined in +-- "Language.Haskell.TH.Instances", from the th-orphans package.+module Language.Haskell.TH.Instances.Lift+ {-# DEPRECATED "Use the th-orphans package instead" #-} () where +import Language.Haskell.TH.Instances