haskell-src-exts-qq (empty) → 0.1
raw patch · 5 files changed
+522/−0 lines, 5 filesdep +basedep +haskell-src-extsdep +sybsetup-changed
Dependencies added: base, haskell-src-exts, syb, template-haskell
Files
- LICENSE +58/−0
- Language/Haskell/Exts/QQ.hs +66/−0
- Language/Haskell/Exts/Translate.hs +359/−0
- Setup.lhs +3/−0
- haskell-src-exts-qq.cabal +36/−0
+ LICENSE view
@@ -0,0 +1,58 @@+Copyright (c) 2010 Mathieu Boespflug++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.++-----------------------------------------------------------------------------++metaquote++Copyright (c) Matt Morrow.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. The names of the author may not be used to endorse or promote+ products derived from this software without specific prior written+ permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Language/Haskell/Exts/QQ.hs view
@@ -0,0 +1,66 @@+module Language.Haskell.Exts.QQ (hs, dec) where++import qualified Language.Haskell.Exts.Syntax as Hs+import qualified Language.Haskell.Exts.Parser as Hs+import qualified Language.Haskell.Exts.Extension as Hs+import qualified Language.Haskell.Exts.Translate as Hs+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Lib+import Data.Generics+import Data.List (intercalate)+++hs = QuasiQuoter { quoteExp = Hs.parseExpWithMode+ Hs.defaultParseMode{Hs.extensions = Hs.knownExtensions}+ `project` antiquoteExp+ , quotePat = Hs.parsePat `project` antiquotePat+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 613+ , quoteType = error "Unimplemented."+ , quoteDec = error "Unimplemented."+#endif+ }++dec = QuasiQuoter { quoteExp = Hs.parseDeclWithMode+ Hs.defaultParseMode{Hs.extensions = Hs.knownExtensions}+ `project` antiquoteExp+ , quotePat = Hs.parsePat `project` antiquotePat+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 613+ , quoteType = error "Unimplemented."+ , quoteDec = error "Unimplemented."+#endif+ }++project f k s = case f s of+ Hs.ParseOk x -> k x+ Hs.ParseFailed loc err -> fail err++-- | The generic functions in 'Language.Haskell.TH.Quote' don't use global+-- names for syntax constructors. This has the unfortunate effect of breaking+-- quotation when the haskell-src-exts syntax module is imported qualified.+-- The solution is to set the flavour of all names to 'NameG'.+qualify :: Name -> Name+-- Need special cases for constructors used in string literals. Assume nearly+-- all else is a datatype defined in Syntax module of haskell-src-exts.+qualify n | ":" <- nameBase n = n+ | "[]" <- nameBase n = n+ | "Nothing" <- nameBase n = n+ | "Just" <- nameBase n = n+ | "SrcLoc" <- nameBase n = Name (mkOccName (nameBase n)) (flav "SrcLoc")+ | otherwise = Name (mkOccName (nameBase n)) (flav "Syntax")+ where pkg = "haskell-src-exts-" ++ VERSION_haskell_src_exts+ flav mod = NameG VarName (mkPkgName pkg)+ (mkModName ("Language.Haskell.Exts." ++ mod))++antiquoteExp :: Data a => a -> Q Exp+antiquoteExp t = dataToQa (conE . qualify) litE (foldl appE)+ (const Nothing `extQ` antiE `extQ` antiP) t+ where antiE (Hs.SpliceExp (Hs.IdSplice v)) = Just $ varE $ mkName v+ antiE (Hs.SpliceExp (Hs.ParenSplice e)) = Just $ return $ Hs.toExp e+ antiE _ = Nothing+ antiP (Hs.PParen (Hs.PParen (Hs.PVar (Hs.Ident n)))) =+ Just $ appE [| Hs.PVar |] (varE (mkName n))+ antiP _ = Nothing++antiquotePat :: Data a => a -> Q Pat+antiquotePat = dataToQa qualify litP conP (const Nothing)
+ Language/Haskell/Exts/Translate.hs view
@@ -0,0 +1,359 @@+{- |+ 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+class ToKind a where toKind :: a -> Kind+class ToPred a where toPred :: a -> Pred+class ToTyVarBndr a where toTyVarBndr :: a -> TyVarBndr+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++{- |+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)++{- |+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 toTyVarBndr) tvbM) (fmap toPred 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.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)+ = TySynD (toName n) (fmap toTyVarBndr ns) (toType t)+++ toDec a@(Hs.DataDecl _ dOrN cxt n ns qcds qns)+ = case dOrN of+ Hs.DataType -> DataD (fmap toPred cxt)+ (toName n)+ (fmap toTyVarBndr ns)+ (fmap qualConDeclToCon qcds)+ (fmap (toName . fst) qns)+ Hs.NewType -> let qcd = case qcds of+ x:_ -> x+ _ -> error "toDec: Newtype has no constructors!"+ in NewtypeD (fmap toPred cxt)+ (toName n)+ (fmap toTyVarBndr ns)+ (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) = ForallC (fmap toTyVarBndr ns)+ (fmap toPred cxt)+ (conDeclToCon cdecl)++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
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ haskell-src-exts-qq.cabal view
@@ -0,0 +1,36 @@+Name: haskell-src-exts-qq+Version: 0.1+Author: Mathieu Boespflug+Maintainer: Mathieu Boespflug <mboes@tweag.net>+Synopsis: A quasiquoter for haskell-src-exts.+Description:+ Allows one to write programs that generate Haskell programs much+ more concisely and legibly. This package supports:+ .+ * Antiquotations, denoted by stealing the splice syntax of+ Template Haskell, for example @[hs| $x ++ $(Hs.strE "bar") |]@.+ Splices may not nested.++ * Antiquoting names in patterns. Names that are antiquoted appear+ surrounded by double parentheses. For instance:+ .+ > let f = Hs.name "foo" in [hs| ((f)) x = x + x |]+Category: Language+License: BSD3+License-File: LICENSE+Cabal-Version: >= 1.8.0+Build-Type: Simple+Tested-With: GHC == 6.12++source-repository head+ type: git+ location: git://github.com/mboes/haskell-src-exts-qq++library+ Build-Depends: base >= 4 && < 5, syb, template-haskell,+ -- xxx awaiting cabal fix.+ haskell-src-exts == 1.8.2+ Extensions: PatternGuards, TypeSynonymInstances, TemplateHaskell, CPP+ Exposed-Modules: Language.Haskell.Exts.QQ+ Language.Haskell.Exts.Translate+ cpp-options: -DVERSION_haskell_src_exts="1.8.2"