diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -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) diff --git a/README b/README --- a/README +++ b/README @@ -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) diff --git a/haskell-src-meta.cabal b/haskell-src-meta.cabal --- a/haskell-src-meta.cabal +++ b/haskell-src-meta.cabal @@ -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 @@ -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 diff --git a/src/Language/Haskell/Meta.hs b/src/Language/Haskell/Meta.hs --- a/src/Language/Haskell/Meta.hs +++ b/src/Language/Haskell/Meta.hs @@ -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() diff --git a/src/Language/Haskell/Meta/Syntax/Translate.hs b/src/Language/Haskell/Meta/Syntax/Translate.hs --- a/src/Language/Haskell/Meta/Syntax/Translate.hs +++ b/src/Language/Haskell/Meta/Syntax/Translate.hs @@ -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] diff --git a/src/Language/Haskell/Meta/Utils.hs b/src/Language/Haskell/Meta/Utils.hs --- a/src/Language/Haskell/Meta/Utils.hs +++ b/src/Language/Haskell/Meta/Utils.hs @@ -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 ----------------------------------------------------------------------------- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/src/Language/Haskell/TH/Instances/Lift.hs b/src/Language/Haskell/TH/Instances/Lift.hs --- a/src/Language/Haskell/TH/Instances/Lift.hs +++ b/src/Language/Haskell/TH/Instances/Lift.hs @@ -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