haskell-src-exts-qq 0.3.0 → 0.4.0

raw patch · 3 files changed

+9/−411 lines, 3 filesdep +haskell-src-metadep ~haskell-src-extsPVP ok

version bump matches the API change (PVP)

Dependencies added: haskell-src-meta

Dependency ranges changed: haskell-src-exts

API changes (from Hackage documentation)

Files

• Language/Haskell/Exts/QQ.hs +1/−1
• Language/Haskell/Exts/Translate.hs +0/−401
• haskell-src-exts-qq.cabal +8/−9

@@ -16,7 +16,7 @@ module Language.Haskell.Exts.QQ (hs, dec, hsWithMode, decWithMode) where  import qualified Language.Haskell.Exts as Hs-import qualified Language.Haskell.Exts.Translate as Hs+import qualified Language.Haskell.Meta.Syntax.Translate as Hs import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote import Language.Haskell.TH.Lib

@@ -1,401 +0,0 @@-{- |-  Module      :  Language.Haskell.Meta.Syntax.Translate-  Copyright   :  (c) Matt Morrow 2008-  License     :  BSD3-  Maintainer  :  Matt Morrow <mjm2002@gmail.com>-  Stability   :  experimental-  Portability :  portable (template-haskell)--}--module Language.Haskell.Exts.Translate where--import Data.Typeable-import Data.List (foldl')-import Language.Haskell.TH.Syntax-import qualified Language.Haskell.Exts.Syntax as Hs---errorMsg :: (Typeable a) => String -> a -> String-errorMsg fun a = concat-  [ fun,": "-  , show . typeRepTyCon . typeOf $ a-  , " not (yet?) implemented"-  ]--class ToName a where toName :: a -> Name-class ToLit  a where toLit  :: a -> Lit-#if MIN_VERSION_template_haskell(2,4,0)-class ToKind a where toKind :: a -> Kind-class ToPred a where toPred :: a -> Pred-class ToTyVarBndr a where toTyVarBndr :: a -> TyVarBndr-#endif-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---- * Literals--instance ToExp Lit where-  toExp = LitE-instance (ToExp a) => ToExp [a] where-  toExp = ListE . fmap toExp-instance (ToExp a, ToExp b) => ToExp (a,b) where-  toExp (a,b) = TupE [toExp a, toExp b]-instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where-  toExp (a,b,c) = TupE [toExp a, toExp b, toExp c]-instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where-  toExp (a,b,c,d) = TupE [toExp a, toExp b, toExp c, toExp d]--instance ToPat Lit where-  toPat = LitP-instance (ToPat a) => ToPat [a] where-  toPat = ListP . fmap toPat-instance (ToPat a, ToPat b) => ToPat (a,b) where-  toPat (a,b) = TupP [toPat a, toPat b]-instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where-  toPat (a,b,c) = TupP [toPat a, toPat b, toPat c]-instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where-  toPat (a,b,c,d) = TupP [toPat a, toPat b, toPat c, toPat d]--instance ToLit Char where-  toLit = CharL-instance ToLit String where-  toLit = StringL-instance ToLit Integer where-  toLit = IntegerL-instance ToLit Int where-  toLit = IntegerL . toInteger-instance ToLit Float where-  toLit = RationalL . toRational-instance ToLit Double where-  toLit = RationalL . toRational--instance ToLit Hs.Literal where-  toLit (Hs.Char a) = CharL a-  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-  toLit (Hs.PrimString a) = StringL a  -- XXX-  toLit (Hs.PrimInt a) = IntPrimL a-  toLit (Hs.PrimFloat a) = FloatPrimL a-  toLit (Hs.PrimDouble a) = DoublePrimL a----- * ToName {String,HsName,Module,HsSpecialCon,HsQName}--instance ToName String where-  toName = mkName--instance ToName Hs.Name where-  toName (Hs.Ident s) = toName s-  toName (Hs.Symbol s) = toName s--instance ToName Hs.Module where-  toName (Hs.Module _ (Hs.ModuleName s) _ _ _ _ _) = toName s--instance ToName Hs.SpecialCon where-  toName Hs.UnitCon = '()-  toName Hs.ListCon = '[]-  toName Hs.FunCon  = ''(->)-  toName (Hs.TupleCon _ n)-    | n<2 = '()-    | otherwise =-      let x = maybe [] (++".") (nameModule '())-      in toName . concat $ x : ["(",replicate (n-1) ',',")"]-  toName Hs.Cons    = '(:)--instance ToName Hs.QName where-  toName (Hs.Qual (Hs.ModuleName []) n) = toName n-  toName (Hs.Qual (Hs.ModuleName m) n) =-    let m' = show . toName $ m-        n' = show . toName $ n-    in toName . concat $ [m',".",n']-  toName (Hs.UnQual n) = toName n-  toName (Hs.Special s) = toName s---- * ToPat HsPat--instance ToPat Hs.Pat where-  toPat (Hs.PVar n)-    = VarP (toName n)-  toPat (Hs.PLit l)-    = LitP (toLit l)-{--ghci> parseHsPat "-2"-Right (HsPParen (HsPNeg (HsPLit (HsInt 2))))--}-  toPat (Hs.PNeg p) = error "toPat: HsPNeg not supported"-  toPat (Hs.PInfixApp p n q)= InfixP (toPat p) (toName n) (toPat q)-  toPat (Hs.PApp n ps) = ConP (toName n) (fmap toPat ps)-  toPat (Hs.PTuple ps) = TupP (fmap toPat ps)-  toPat (Hs.PList ps) = ListP (fmap toPat ps)-  toPat (Hs.PParen p) = toPat p-  toPat (Hs.PRec n pfs) = let toFieldPat (Hs.PFieldPat n p) = (toName n, toPat p)-                          in RecP (toName n) (fmap toFieldPat pfs)-  toPat (Hs.PAsPat n p) = AsP (toName n) (toPat p)-  toPat (Hs.PWildCard) = WildP-  toPat (Hs.PIrrPat p) = TildeP (toPat p)-  toPat (Hs.PatTypeSig _ p t) = SigP (toPat p) (toType t)-  toPat (Hs.PRPat rps) = error "toPat: HsRPat not supported"-  toPat (Hs.PXTag _ _ _ pM p) = error "toPat: HsPXTag not supported"-  toPat (Hs.PXETag _ _ _ pM) = error "toPat: HsPXETag not supported"-  toPat (Hs.PXPcdata _) = error "toPat: HsPXPcdata not supported"-  toPat (Hs.PXPatTag p) = error "toPat: HsPXPatTag not supported"---- * ToExp HsExp--instance ToExp Hs.QOp where-  toExp (Hs.QVarOp n) = VarE (toName n)-  toExp (Hs.QConOp n) = ConE (toName n)--toFieldExp :: Hs.FieldUpdate -> FieldExp-toFieldExp (Hs.FieldUpdate n e) = (toName n, toExp e)--instance ToExp Hs.Exp where-  toExp (Hs.Var n)                 = VarE (toName n)-  toExp (Hs.Con n)                 = ConE (toName n)-  toExp (Hs.Lit l)                 = LitE (toLit l)-  toExp (Hs.InfixApp e o f)        = InfixE (Just . toExp $ e) (toExp o) (Just . toExp $ f)-  toExp (Hs.LeftSection e o)       = InfixE (Just . toExp $ e) (toExp o) Nothing-  toExp (Hs.RightSection o f)      = InfixE Nothing (toExp o) (Just . toExp $ f)-  toExp (Hs.App e f)               = AppE (toExp e) (toExp f)-  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 (Hs.If a b c)              = CondE (toExp a) (toExp b) (toExp c)-  toExp (Hs.Tuple xs)              = TupE (fmap toExp xs)-  toExp (Hs.List xs)               = ListE (fmap toExp xs)-  toExp (Hs.Paren e)               = toExp e-  toExp (Hs.RecConstr n xs)        = RecConE (toName n) (fmap toFieldExp xs)-  toExp (Hs.RecUpdate e xs)        = RecUpdE (toExp e) (fmap toFieldExp xs)-  toExp (Hs.EnumFrom e)            = ArithSeqE $ FromR (toExp e)-  toExp (Hs.EnumFromTo e f)        = ArithSeqE $ FromToR (toExp e) (toExp f)-  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)-  toExp a@(Hs.ListComp e ss)       = error $ errorMsg "toExp" a-  toExp a@(Hs.SpliceExp spl) = error $ errorMsg "toExp" a-  toExp e = error $ errorMsg "toExp" e---- * ToLoc SrcLoc--instance ToLoc Hs.SrcLoc where-  toLoc (Hs.SrcLoc fn l c) =-    Loc fn [] [] (l,c) (-1,-1)---- * ToType HsType---#if MIN_VERSION_template_haskell(2,4,0)-{- |-TH doesn't handle:-  * !, the kind of unboxed types-  * kind variables (as of yet unsupported by compilers)--}-instance ToKind Hs.Kind where-  toKind Hs.KindStar = StarK-  toKind (Hs.KindFn k1 k2) = ArrowK (toKind k1) (toKind k2)-  toKind (Hs.KindParen k) = toKind k-  toKind a@Hs.KindBang = error $ errorMsg "toKind" a-  toKind a@(Hs.KindVar _) = error $ errorMsg "toKind" a--{- |-TH doesn't handle:-  * implicit params--}-instance ToPred Hs.Asst where-  toPred (Hs.ClassA n ts) = ClassP (toName n) (fmap toType ts)-  toPred a@(Hs.EqualP ty1 ty2) = EqualP (toType ty1) (toType ty2)-  toPred a@(Hs.IParam _ _) = error $ errorMsg "toType" a--instance ToTyVarBndr Hs.TyVarBind where-  toTyVarBndr (Hs.KindedVar n k) = KindedTV (toName n) (toKind k)-  toTyVarBndr (Hs.UnkindedVar n) = PlainTV (toName n)-#else-instance ToName Hs.TyVarBind where-  toName (Hs.KindedVar n _) = toName n-  toName (Hs.UnkindedVar n) = toName n--instance ToType Hs.Asst where-  toType (Hs.ClassA n ts) = foldAppT (ConT . toName $ n) (fmap toType ts)-  toType a@(Hs.IParam _ _) = error $ errorMsg "toType" a-  toType a@(Hs.EqualP _ _) = error $ errorMsg "toType" a-#endif--{- |-TH does't handle-  * unboxed tuples-  * implicit params-  * infix type constructors-  * kind signatures--}-instance ToType Hs.Type where-#if MIN_VERSION_template_haskell(2,4,0)-  toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toTyVarBndr) tvbM) (fmap toPred cxt) (toType t)-#else-  toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toName) tvbM) (fmap toType cxt) (toType t)-#endif-  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.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--(.->.) :: Type -> Type -> Type-a .->. b = AppT (AppT ArrowT a) b--foldAppT :: Type -> [Type] -> Type-foldAppT t ts = foldl' AppT t ts---- * ToStmt HsStmt--instance ToStmt Hs.Stmt where-  toStmt (Hs.Generator _ p e)  = BindS (toPat p) (toExp e)-  toStmt (Hs.Qualifier e)      = NoBindS (toExp e)-  toStmt a@(Hs.LetStmt bnds)   = LetS (hsBindsToDecs bnds)---- * ToDec HsDecl--hsBindsToDecs :: Hs.Binds -> [Dec]-hsBindsToDecs (Hs.BDecls ds) = fmap toDec ds-hsBindsToDecs a@(Hs.IPBinds ipbs) = error $ errorMsg "hsBindsToDecs" a--hsBangTypeToStrictType :: Hs.BangType -> (Strict, Type)-hsBangTypeToStrictType (Hs.BangedTy t)   = (IsStrict, toType t)-hsBangTypeToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)--instance ToDec Hs.Decl where-  toDec (Hs.TypeDecl _ n ns t)-#if MIN_VERSION_template_haskell(2,4,0)-    = TySynD (toName n) (fmap toTyVarBndr ns) (toType t)-#else-    = TySynD (toName n) (fmap toName ns) (toType t)-#endif--  toDec a@(Hs.DataDecl  _ dOrN cxt n ns qcds qns)-    = case dOrN of-        Hs.DataType -> DataD-#if MIN_VERSION_template_haskell(2,4,0)-                              (fmap toPred cxt)-#else-                              (fmap toType cxt)-#endif-                              (toName n)-#if MIN_VERSION_template_haskell(2,4,0)-                              (fmap toTyVarBndr ns)-#else-                              (fmap toName ns)-#endif-                              (fmap qualConDeclToCon qcds)-                              (fmap (toName . fst) qns)-        Hs.NewType  -> let qcd = case qcds of-                                  x:_ -> x-                                  _   -> error "toDec: Newtype has no constructors!"-                        in NewtypeD-#if MIN_VERSION_template_haskell(2,4,0)-                                    (fmap toPred cxt)-#else-                                    (fmap toType cxt)-#endif-                                    (toName n)-#if MIN_VERSION_template_haskell(2,4,0)-                                    (fmap toTyVarBndr ns)-#else-                                    (fmap toName ns)-#endif-                                    (qualConDeclToCon qcd)-                                    (fmap (toName . fst) qns)--  toDec a@(Hs.GDataDecl _ dOrN cxt n ns kM gadtDecs _) = error $ errorMsg "toDec" a-  toDec a@(Hs.TypeFamDecl _ n ns kM)                   = error $ errorMsg "toDec" a-  toDec a@(Hs.DataFamDecl _ cxt n ns kM)               = error $ errorMsg "toDec" a-  toDec a@(Hs.TypeInsDecl _ ta tb)                     = error $ errorMsg "toDec" a-  toDec a@(Hs.DataInsDecl _ dOrN t qcds qns)           = error $ errorMsg "toDec" a-  toDec a@(Hs.GDataInsDecl _ dOrN t kM gadtDecs _)     = error $ errorMsg "toDec" a--- data HsOp = HsVarOp HsName | HsConOp HsName-  toDec a@(Hs.InfixDecl _ asst i ops)                  = error $ errorMsg "toDec" a-  toDec a@(Hs.ClassDecl _ cxt n ns funDeps cDecs)      = error $ errorMsg "toDec" a-  toDec a@(Hs.InstDecl _ cxt qn ts instDecs)           = error $ errorMsg "toDec" a-  toDec a@(Hs.DerivDecl _ cxt qn ts)                   = error $ errorMsg "toDec" a-  toDec a@(Hs.DefaultDecl _ ts)                        = error $ errorMsg "toDec" a-  toDec a@(Hs.SpliceDecl _ s)                          = error $ errorMsg "toDec" a-  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!"---  toDec a@(Hs.FunBind mtchs)                           = hsMatchesToFunD mtchs-  toDec (Hs.PatBind _ p tM rhs bnds)                   = ValD ((maybe id-                                                                      (flip SigP . toType)-                                                                      tM) (toPat p))-                                                              (hsRhsToBody rhs)-                                                              (hsBindsToDecs bnds)-  toDec a@(Hs.ForImp _ cconv safe str n t)             = error $ errorMsg "toDec" a-  toDec a@(Hs.ForExp _ cconv      str n t)             = error $ errorMsg "toDec" a--qualConDeclToCon :: Hs.QualConDecl -> Con-qualConDeclToCon (Hs.QualConDecl _ [] [] cdecl) = conDeclToCon cdecl-qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) =-#if MIN_VERSION_template_haskell(2,4,0)-  ForallC (fmap toTyVarBndr ns) (fmap toPred cxt) (conDeclToCon cdecl)-#else-  ForallC (fmap toName ns) (fmap toType cxt) (conDeclToCon cdecl)-#endif--conDeclToCon :: Hs.ConDecl -> Con-conDeclToCon (Hs.ConDecl n tys)-  = NormalC (toName n) (fmap bangToStrictType tys)-conDeclToCon (Hs.RecDecl n lbls)-  = 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--bangToStrictType :: Hs.BangType -> StrictType-bangToStrictType (Hs.BangedTy   t) = (IsStrict, toType t)-bangToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)-bangToStrictType (Hs.UnpackedTy t) = (IsStrict, toType t)--hsMatchesToFunD :: [Hs.Match] -> Dec-hsMatchesToFunD [] = FunD (mkName []) []   -- errorish-hsMatchesToFunD xs@(Hs.Match _ n _ _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs)--hsMatchToClause :: Hs.Match -> Clause-hsMatchToClause (Hs.Match _ _ ps _ rhs bnds) = Clause-                                                (fmap toPat ps)-                                                (hsRhsToBody rhs)-                                                (hsBindsToDecs bnds)--hsRhsToBody :: Hs.Rhs -> Body-hsRhsToBody (Hs.UnGuardedRhs e) = NormalB (toExp e)-hsRhsToBody (Hs.GuardedRhss hsgrhs) = let fromGuardedB (GuardedB a) = a-                                      in GuardedB . concat-                                          . fmap (fromGuardedB . hsGuardedRhsToBody)-                                              $ hsgrhs--hsGuardedRhsToBody :: Hs.GuardedRhs -> Body-hsGuardedRhsToBody (Hs.GuardedRhs _ [] e)  = NormalB (toExp e)-hsGuardedRhsToBody (Hs.GuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)]-hsGuardedRhsToBody (Hs.GuardedRhs _ ss e)  = let ss' = fmap hsStmtToGuard ss-                                                 (pgs,ngs) = unzip [(p,n)-                                                               | (PatG p) <- ss'-                                                               , n@(NormalG _) <- ss']-                                                 e' = toExp e-                                                 patg = PatG (concat pgs)-                                            in GuardedB $ (patg,e') : zip ngs (repeat e')--hsStmtToGuard :: Hs.Stmt -> Guard-hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)]-hsStmtToGuard (Hs.Qualifier e)     = NormalG (toExp e)-hsStmtToGuard a@(Hs.LetStmt _)     = error $ errorMsg "hsStmtToGuardExp" a

@@ -1,5 +1,5 @@ Name:           haskell-src-exts-qq-Version:        0.3.0+Version:        0.4.0 Author:         Mathieu Boespflug Maintainer:     Mathieu Boespflug <mboes@tweag.net> Synopsis:       A quasiquoter for haskell-src-exts.@@ -18,9 +18,9 @@ Category:       Language License:        BSD3 License-File:   LICENSE-Cabal-Version:  >= 1.8.0+Cabal-Version:  >= 1.10.0 Build-Type:     Simple-Tested-With:    GHC == 6.12+Tested-With:    GHC == 7.0.1  source-repository head   type:     git@@ -28,9 +28,8 @@  library   Build-Depends:  base >= 4 && < 5, syb, template-haskell,-                  -- xxx awaiting cabal fix.-                  haskell-src-exts == 1.9.0-  Extensions:      PatternGuards, TypeSynonymInstances, TemplateHaskell, CPP-  Exposed-Modules: Language.Haskell.Exts.QQ-                   Language.Haskell.Exts.Translate-  cpp-options:    -DVERSION_haskell_src_exts="1.9.0"+                  haskell-src-exts >= 1.9.0,+                  haskell-src-meta >= 0.3+  Default-Language:     Haskell2010+  Default-Extensions:   TemplateHaskell, CPP+  Exposed-Modules:      Language.Haskell.Exts.QQ