diff --git a/Language/Haskell/Exts/QQ.hs b/Language/Haskell/Exts/QQ.hs --- a/Language/Haskell/Exts/QQ.hs +++ b/Language/Haskell/Exts/QQ.hs @@ -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 diff --git a/Language/Haskell/Exts/Translate.hs b/Language/Haskell/Exts/Translate.hs deleted file mode 100644 --- a/Language/Haskell/Exts/Translate.hs +++ /dev/null @@ -1,401 +0,0 @@ -{- | - Module : Language.Haskell.Meta.Syntax.Translate - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Matt Morrow - 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 diff --git a/haskell-src-exts-qq.cabal b/haskell-src-exts-qq.cabal --- a/haskell-src-exts-qq.cabal +++ b/haskell-src-exts-qq.cabal @@ -1,5 +1,5 @@ Name: haskell-src-exts-qq -Version: 0.3.0 +Version: 0.4.0 Author: Mathieu Boespflug Maintainer: Mathieu Boespflug 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