haskell-src-meta-0.8.2/examples/0000755000000000000000000000000013432620647014670 5ustar0000000000000000haskell-src-meta-0.8.2/src/0000755000000000000000000000000013432550531013633 5ustar0000000000000000haskell-src-meta-0.8.2/src/Language/0000755000000000000000000000000013432550531015356 5ustar0000000000000000haskell-src-meta-0.8.2/src/Language/Haskell/0000755000000000000000000000000013432550531016741 5ustar0000000000000000haskell-src-meta-0.8.2/src/Language/Haskell/Meta/0000755000000000000000000000000013435377203017635 5ustar0000000000000000haskell-src-meta-0.8.2/src/Language/Haskell/Meta/Syntax/0000755000000000000000000000000013435374604021125 5ustar0000000000000000haskell-src-meta-0.8.2/tests/0000755000000000000000000000000013435374604014216 5ustar0000000000000000haskell-src-meta-0.8.2/src/Language/Haskell/Meta.hs0000644000000000000000000000074213432550531020166 0ustar0000000000000000{- | Module : Language.Haskell.Meta Copyright : (c) Matt Morrow 2008 License : BSD3 Maintainer : Matt Morrow Stability : experimental Portability : portable (template-haskell) -} module Language.Haskell.Meta ( module Language.Haskell.Meta.Parse, module Language.Haskell.Meta.Syntax.Translate ) where import Language.Haskell.Meta.Parse import Language.Haskell.Meta.Syntax.Translate import Language.Haskell.TH.Instances() haskell-src-meta-0.8.2/src/Language/Haskell/Meta/Parse.hs0000644000000000000000000001172213435377203021246 0ustar0000000000000000{-# LANGUAGE CPP #-} {- | Module : Language.Haskell.Meta.Parse Copyright : (c) Matt Morrow 2008 License : BSD3 Maintainer : Matt Morrow Stability : experimental Portability : portable (template-haskell) -} module Language.Haskell.Meta.Parse ( parsePat, parseExp, parseType, parseDecs, parseDecsWithMode, myDefaultParseMode, myDefaultExtensions, parseResultToEither, parseHsModule, parseHsDecls, parseHsDeclsWithMode, parseHsType, parseHsExp, parseHsPat, pprHsModule, moduleDecls, noSrcSpanInfo, emptyHsModule ) where #if MIN_VERSION_template_haskell(2,11,0) import Language.Haskell.TH.Syntax hiding (Extension(..)) #else import Language.Haskell.TH.Syntax #endif import Language.Haskell.Meta.Syntax.Translate #if MIN_VERSION_haskell_src_exts(1,18,0) import qualified Language.Haskell.Exts.Syntax as Hs import Language.Haskell.Exts.Fixity as Fix import Language.Haskell.Exts.Parser hiding (parseExp, parseType, parsePat) #else import qualified Language.Haskell.Exts.Annotated.Syntax as Hs import Language.Haskell.Exts.Annotated.Fixity as Fix import Language.Haskell.Exts.Annotated.Parser hiding (parseExp, parseType, parsePat) #endif import qualified Language.Haskell.Exts.SrcLoc as Hs import Language.Haskell.Exts.Extension import Language.Haskell.Exts.Pretty import Language.Haskell.Exts.Parser (ParseMode(..), ParseResult(..)) ----------------------------------------------------------------------------- -- * template-haskell parsePat :: String -> Either String Pat parsePat = either Left (Right . toPat) . parseHsPat parseExp :: String -> Either String Exp parseExp = either Left (Right . toExp) . parseHsExp parseType :: String -> Either String Type parseType = either Left (Right . toType) . parseHsType parseDecs :: String -> Either String [Dec] parseDecs = either Left (Right . toDecs) . parseHsDecls -- | @since 0.8.2 parseDecsWithMode :: ParseMode -> String -> Either String [Dec] parseDecsWithMode parseMode = either Left (Right . toDecs) . parseHsDeclsWithMode parseMode ----------------------------------------------------------------------------- {-# DEPRECATED myDefaultParseMode, myDefaultExtensions "The provided ParseModes aren't very meaningful, use your own instead" #-} myDefaultParseMode :: ParseMode myDefaultParseMode = defaultParseMode {parseFilename = [] ,baseLanguage = Haskell2010 ,extensions = map EnableExtension myDefaultExtensions } myDefaultExtensions :: [KnownExtension] myDefaultExtensions = [PostfixOperators ,QuasiQuotes ,UnicodeSyntax ,PatternSignatures ,MagicHash ,ForeignFunctionInterface ,TemplateHaskell ,RankNTypes ,MultiParamTypeClasses ,RecursiveDo] parseResultToEither :: ParseResult a -> Either String a parseResultToEither (ParseOk a) = Right a parseResultToEither (ParseFailed loc e) = let line = Hs.srcLine loc - 1 in Left (unlines [show line,show loc,e]) parseHsModule :: String -> Either String (Hs.Module Hs.SrcSpanInfo) parseHsModule = parseResultToEither . parseModuleWithMode myDefaultParseMode parseHsDecls :: String -> Either String [Hs.Decl Hs.SrcSpanInfo] parseHsDecls = either Left (Right . moduleDecls) . parseResultToEither . parseModuleWithMode myDefaultParseMode -- | @since 0.8.2 parseHsDeclsWithMode :: ParseMode -> String -> Either String [Hs.Decl Hs.SrcSpanInfo] parseHsDeclsWithMode parseMode = either Left (Right . moduleDecls) . parseResultToEither . parseModuleWithMode parseMode parseHsType :: String -> Either String (Hs.Type Hs.SrcSpanInfo) parseHsType = parseResultToEither . parseTypeWithMode myDefaultParseMode parseHsExp :: String -> Either String (Hs.Exp Hs.SrcSpanInfo) parseHsExp = parseResultToEither . parseExpWithMode myDefaultParseMode parseHsPat :: String -> Either String (Hs.Pat Hs.SrcSpanInfo) parseHsPat = parseResultToEither . parsePatWithMode myDefaultParseMode pprHsModule :: Hs.Module Hs.SrcSpanInfo -> String pprHsModule = prettyPrint moduleDecls :: Hs.Module Hs.SrcSpanInfo -> [Hs.Decl Hs.SrcSpanInfo] moduleDecls (Hs.Module _ _ _ _ x) = x -- mkModule :: String -> Hs.Module -- mkModule s = Hs.Module undefined (Hs.ModuleName s) Nothing [] [] emptyHsModule :: String -> Hs.Module Hs.SrcSpanInfo emptyHsModule n = (Hs.Module noSrcSpanInfo (Just (Hs.ModuleHead noSrcSpanInfo (Hs.ModuleName noSrcSpanInfo n) Nothing Nothing)) [] [] []) noSrcSpanInfo = Hs.noInfoSpan (Hs.mkSrcSpan Hs.noLoc Hs.noLoc) {- ghci> :i Module data Module = Module SrcLoc ModuleName [OptionPragma] (Maybe WarningText) (Maybe [ExportSpec]) [ImportDecl] [Decl] -- Defined in Language.Haskell.Exts.Syntax instance Show Module -- Defined in Language.Haskell.Exts.Syntax -} ----------------------------------------------------------------------------- haskell-src-meta-0.8.2/src/Language/Haskell/Meta/Syntax/Translate.hs0000644000000000000000000006432213435374604023425 0ustar0000000000000000{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-} {- | 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.Meta.Syntax.Translate ( module Language.Haskell.Meta.Syntax.Translate ) where import Data.Char (ord) import Data.Typeable import Data.List (foldl', nub, (\\)) import Language.Haskell.TH.Syntax import qualified Language.Haskell.Exts.SrcLoc as Hs #if MIN_VERSION_haskell_src_exts(1,18,0) import qualified Language.Haskell.Exts.Syntax as Hs #else import qualified Language.Haskell.Exts.Annotated.Syntax as Hs #endif ----------------------------------------------------------------------------- class ToName a where toName :: a -> Name class ToNames a where toNames :: 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 ToDecs a where toDecs :: a -> [Dec] class ToDec a where toDec :: a -> Dec class ToStmt a where toStmt :: a -> Stmt class ToLoc a where toLoc :: a -> Loc class ToCxt a where toCxt :: a -> Cxt class ToPred a where toPred :: a -> Pred class ToTyVars a where toTyVars :: a -> [TyVarBndr] #if MIN_VERSION_haskell_src_exts(1,18,0) class ToMaybeKind a where toMaybeKind :: a -> Maybe Kind #endif #if MIN_VERSION_template_haskell(2,11,0) class ToInjectivityAnn a where toInjectivityAnn :: a -> InjectivityAnn #endif #if MIN_VERSION_template_haskell(2,12,0) #elif MIN_VERSION_template_haskell(2,11,0) type DerivClause = Pred #else type DerivClause = Name #endif class ToDerivClauses a where toDerivClauses :: a -> [DerivClause] -- for error messages moduleName = "Language.Haskell.Meta.Syntax.Translate" -- When to use each of these isn't always clear: prefer 'todo' if unsure. noTH :: (Functor f, Show (f ())) => String -> f e -> a noTH fun thing = error . concat $ [moduleName, ".", fun, ": template-haskell has no representation for: ", show (fmap (const ()) thing)] noTHyet :: (Functor f, Show (f ())) => String -> String -> f e -> a noTHyet fun minVersion thing = error . concat $ [moduleName, ".", fun, ": template-haskell-", VERSION_template_haskell, " (< ", minVersion, ")", " has no representation for: ", show (fmap (const ()) thing)] todo :: (Functor f, Show (f ())) => String -> f e -> a todo fun thing = error . concat $ [moduleName, ".", fun, ": not implemented: ", show (fmap (const ()) thing)] nonsense :: (Functor f, Show (f ())) => String -> String -> f e -> a nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun, ": nonsensical: ", inparticular, ": ", show (fmap (const ()) thing)] ----------------------------------------------------------------------------- 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 ----------------------------------------------------------------------------- -- * ToName {String,HsName,Module,HsSpecialCon,HsQName} instance ToName String where toName = mkName instance ToName (Hs.Name l) where toName (Hs.Ident _ s) = toName s toName (Hs.Symbol _ s) = toName s instance ToName (Hs.SpecialCon l) where toName (Hs.UnitCon _) = mkName "()" toName (Hs.ListCon _) = ''[] -- Parser only uses this in types toName (Hs.FunCon _) = ''(->) toName (Hs.TupleCon _ _ n) = mkName $ concat ["(",replicate (n-1) ',',")"] toName (Hs.Cons _) = '(:) instance ToName (Hs.QName l) where -- toName (Hs.Qual (Hs.Module []) n) = toName n 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 instance ToName (Hs.Op l) where toName (Hs.VarOp _ n) = toName n toName (Hs.ConOp _ n) = toName n ----------------------------------------------------------------------------- -- * ToLit HsLiteral instance ToLit (Hs.Literal l) 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 l@Hs.PrimChar{} = noTH "toLit" l toLit (Hs.PrimString _ a _) = StringPrimL (map toWord8 a) where toWord8 = fromIntegral . ord toLit (Hs.PrimInt _ a _) = IntPrimL a toLit (Hs.PrimFloat _ a _) = FloatPrimL a toLit (Hs.PrimDouble _ a _) = DoublePrimL a toLit (Hs.PrimWord _ a _) = WordPrimL a ----------------------------------------------------------------------------- -- * ToPat HsPat instance ToPat (Hs.Pat l) where toPat (Hs.PVar _ n) = VarP (toName n) toPat (Hs.PLit _ (Hs.Signless _) l) = LitP (toLit l) toPat (Hs.PLit _ (Hs.Negative _) l) = LitP $ case toLit l of IntegerL z -> IntegerL (negate z) RationalL q -> RationalL (negate q) IntPrimL z' -> IntPrimL (negate z') FloatPrimL r' -> FloatPrimL (negate r') DoublePrimL r'' -> DoublePrimL (negate r'') _ -> nonsense "toPat" "negating wrong kind of literal" l toPat (Hs.PInfixApp _ p n q) = UInfixP (toPat p) (toName n) (toPat q) toPat (Hs.PApp _ n ps) = ConP (toName n) (fmap toPat ps) toPat (Hs.PTuple _ Hs.Boxed ps) = TupP (fmap toPat ps) toPat (Hs.PTuple _ Hs.Unboxed ps) = UnboxedTupP (fmap toPat ps) toPat (Hs.PList _ ps) = ListP (fmap toPat ps) toPat (Hs.PParen _ p) = ParensP (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.PViewPat _ e p) = ViewP (toExp e) (toPat p) -- regular pattern toPat p@Hs.PRPat{} = noTH "toPat" p -- XML stuff toPat p@Hs.PXTag{} = noTH "toPat" p toPat p@Hs.PXETag{} = noTH "toPat" p toPat p@Hs.PXPcdata{} = noTH "toPat" p toPat p@Hs.PXPatTag{} = noTH "toPat" p toPat (Hs.PBangPat _ p) = BangP (toPat p) toPat p = todo "toPat" p ----------------------------------------------------------------------------- -- * ToExp HsExp instance ToExp (Hs.QOp l) where toExp (Hs.QVarOp _ n) = VarE (toName n) toExp (Hs.QConOp _ n) = ConE (toName n) toFieldExp :: Hs.FieldUpdate l -> FieldExp toFieldExp (Hs.FieldUpdate _ n e) = (toName n, toExp e) instance ToExp (Hs.Exp l) where toExp (Hs.Var _ n) = VarE (toName n) toExp e@Hs.IPVar{} = noTH "toExp" e toExp (Hs.Con _ n) = ConE (toName n) toExp (Hs.Lit _ l) = LitE (toLit l) toExp (Hs.InfixApp _ e o f) = UInfixE (toExp e) (toExp o) (toExp f) #if MIN_VERSION_template_haskell(2,12,0) toExp (Hs.App _ e (Hs.TypeApp _ t)) = AppTypeE (toExp e) (toType t) #else toExp (Hs.App _ e aTypeApp@Hs.TypeApp{}) = noTHyet "toExp" "2.12.0" aTypeApp #endif 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 (toDecs bs) (toExp e) toExp (Hs.If _ a b c) = CondE (toExp a) (toExp b) (toExp c) toExp (Hs.MultiIf _ ifs) = MultiIfE (map toGuard ifs) toExp (Hs.Case _ e alts) = CaseE (toExp e) (map toMatch alts) toExp (Hs.Do _ ss) = DoE (map toStmt ss) toExp e@(Hs.MDo _ _) = noTH "toExp" e toExp (Hs.Tuple _ Hs.Boxed xs) = TupE (fmap toExp xs) toExp (Hs.Tuple _ Hs.Unboxed xs) = UnboxedTupE (fmap toExp xs) toExp e@Hs.TupleSection{} = noTH "toExp" e toExp (Hs.List _ xs) = ListE (fmap toExp xs) toExp (Hs.Paren _ e) = ParensE (toExp e) 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.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.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.ExpTypeSig _ e t) = SigE (toExp e) (toType t) toExp e = todo "toExp" e toMatch :: Hs.Alt l -> Match toMatch (Hs.Alt _ p rhs ds) = Match (toPat p) (toBody rhs) (toDecs ds) toBody :: Hs.Rhs l -> Body toBody (Hs.UnGuardedRhs _ e) = NormalB $ toExp e toBody (Hs.GuardedRhss _ rhss) = GuardedB $ map toGuard rhss toGuard (Hs.GuardedRhs _ stmts e) = (g, toExp e) where g = case map toStmt stmts of [NoBindS x] -> NormalG x xs -> PatG xs instance ToDecs a => ToDecs (Maybe a) where toDecs Nothing = [] toDecs (Just a) = toDecs a instance ToDecs (Hs.Binds l) where toDecs (Hs.BDecls _ ds) = toDecs ds toDecs a@(Hs.IPBinds {}) = noTH "ToDecs Hs.Binds" a instance ToDecs (Hs.ClassDecl l) where toDecs (Hs.ClsDecl _ d) = toDecs d toDecs x = todo "classDecl" x ----------------------------------------------------------------------------- -- * ToLoc SrcLoc instance ToLoc Hs.SrcLoc where toLoc (Hs.SrcLoc fn l c) = Loc fn [] [] (l,c) (-1,-1) ----------------------------------------------------------------------------- -- * ToType HsType instance ToName (Hs.TyVarBind l) where toName (Hs.KindedVar _ n _) = toName n toName (Hs.UnkindedVar _ n) = toName n instance ToName Name where toName = id instance ToName TyVarBndr where toName (PlainTV n) = n toName (KindedTV n _) = n #if !MIN_VERSION_haskell_src_exts(1,21,0) instance ToType (Hs.Kind l) where toType (Hs.KindStar _) = StarT toType (Hs.KindFn _ k1 k2) = toType k1 .->. toType k2 toType (Hs.KindParen _ kp) = toType kp toType (Hs.KindVar _ n) = VarT (toName n) #endif toKind :: Hs.Kind l -> Kind toKind = toType toTyVar :: Hs.TyVarBind l -> TyVarBndr toTyVar (Hs.KindedVar _ n k) = KindedTV (toName n) (toKind k) toTyVar (Hs.UnkindedVar _ n) = PlainTV (toName n) instance ToType (Hs.Type l) 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 _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts) where tuple = case b of Hs.Boxed -> TupleT Hs.Unboxed -> UnboxedTupleT 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! #if MIN_VERSION_haskell_src_exts(1,20,0) toType (Hs.TyInfix _ a (Hs.UnpromotedName _ o) b) = #else toType (Hs.TyInfix _ a o b) = #endif AppT (AppT (ConT (toName o)) (toType a)) (toType b) toType (Hs.TyKind _ t k) = SigT (toType t) (toKind k) toType t@Hs.TyBang{} = nonsense "toType" "type cannot have strictness annotations in this context" t toStrictType :: Hs.Type l -> StrictType #if MIN_VERSION_template_haskell(2,11,0) toStrictType (Hs.TyBang _ s u t) = (Bang (toUnpack u) (toStrict s), toType t) where toStrict (Hs.LazyTy _) = SourceLazy toStrict (Hs.BangedTy _) = SourceStrict toStrict (Hs.NoStrictAnnot _) = NoSourceStrictness toUnpack (Hs.Unpack _) = SourceUnpack toUnpack (Hs.NoUnpack _) = SourceNoUnpack toUnpack (Hs.NoUnpackPragma _) = NoSourceUnpackedness toStrictType x = (Bang NoSourceUnpackedness NoSourceStrictness, toType x) #elif MIN_VERSION_haskell_src_exts(1,18,0) -- TyBang l (BangType l) (Unpackedness l) (Type l) -- data BangType l = BangedTy l | LazyTy l | NoStrictAnnot l -- data Unpackedness l = Unpack l | NoUnpack l | NoUnpackPragma l toStrictType (Hs.TyBang _ b u t) = (toStrict b u, toType t) where toStrict :: Hs.BangType l -> Hs.Unpackedness l -> Strict toStrict (Hs.BangedTy _) _ = IsStrict toStrict _ (Hs.Unpack _) = Unpacked toStrict _ _ = NotStrict toStrictType x = (NotStrict, toType x) #else toStrictType t@(Hs.TyBang _ _ Hs.TyBang{}) = nonsense "toStrictType" "double strictness annotation" t toStrictType (Hs.TyBang _ (Hs.BangedTy _) t) = (IsStrict, toType t) toStrictType (Hs.TyBang _ (Hs.UnpackedTy _) t) = (Unpacked, toType t) toStrictType t = (NotStrict, toType t) #endif (.->.) :: Type -> Type -> Type a .->. b = AppT (AppT ArrowT a) b instance ToPred (Hs.Asst l) where #if MIN_VERSION_template_haskell(2,10,0) toPred (Hs.ClassA _ n ts) = foldl' AppT (ConT (toName n)) (fmap toType ts) toPred (Hs.InfixA _ t1 n t2) = foldl' AppT (ConT (toName n)) (fmap toType [t1,t2]) toPred (Hs.EqualP _ t1 t2) = foldl' AppT EqualityT (fmap toType [t1,t2]) #else toPred (Hs.ClassA _ n ts) = ClassP (toName n) (fmap toType ts) toPred (Hs.InfixA _ t1 n t2) = ClassP (toName n) (fmap toType [t1, t2]) toPred (Hs.EqualP _ t1 t2) = EqualP (toType t1) (toType t2) #endif toPred a@Hs.IParam{} = noTH "toCxt" a toPred p = todo "toPred" p #if MIN_VERSION_template_haskell(2,12,0) instance ToDerivClauses (Hs.Deriving l) where #if MIN_VERSION_haskell_src_exts(1,20,0) toDerivClauses (Hs.Deriving _ strat irules) = [DerivClause (fmap toDerivStrategy strat) (map toType irules)] #else toDerivClauses (Hs.Deriving _ irules) = [DerivClause Nothing (map toType irules)] #endif #else instance ToDerivClauses (Hs.Deriving l) where #if MIN_VERSION_haskell_src_exts(1,20,0) toDerivClauses (Hs.Deriving _ _ irules) = #else toDerivClauses (Hs.Deriving _ irules) = #endif #if MIN_VERSION_template_haskell(2,11,0) map toType irules #else concatMap toNames irules #endif #endif instance ToDerivClauses a => ToDerivClauses (Maybe a) where toDerivClauses Nothing = [] toDerivClauses (Just a) = toDerivClauses a instance ToDerivClauses a => ToDerivClauses [a] where toDerivClauses = concatMap toDerivClauses #if MIN_VERSION_template_haskell(2,12,0) && MIN_VERSION_haskell_src_exts(1,20,0) toDerivStrategy :: (Hs.DerivStrategy l) -> DerivStrategy toDerivStrategy (Hs.DerivStock _) = StockStrategy toDerivStrategy (Hs.DerivAnyclass _) = AnyclassStrategy toDerivStrategy (Hs.DerivNewtype _) = NewtypeStrategy #endif foldAppT :: Type -> [Type] -> Type foldAppT t ts = foldl' AppT t ts ----------------------------------------------------------------------------- -- * ToStmt HsStmt instance ToStmt (Hs.Stmt l) where toStmt (Hs.Generator _ p e) = BindS (toPat p) (toExp e) toStmt (Hs.Qualifier _ e) = NoBindS (toExp e) toStmt a@(Hs.LetStmt _ bnds) = LetS (toDecs bnds) toStmt s@Hs.RecStmt{} = noTH "toStmt" s ----------------------------------------------------------------------------- -- * ToDec HsDecl instance ToDec (Hs.Decl l) where toDec (Hs.TypeDecl _ h t) = TySynD (toName h) (toTyVars h) (toType t) toDec a@(Hs.DataDecl _ dOrN cxt h qcds qns) = case dOrN of Hs.DataType _ -> DataD (toCxt cxt) (toName h) (toTyVars h) #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif (fmap qualConDeclToCon qcds) (toDerivClauses qns) Hs.NewType _ -> let qcd = case qcds of [x] -> x _ -> nonsense "toDec" ("newtype with " ++ "wrong number of constructors") a in NewtypeD (toCxt cxt) (toName h) (toTyVars h) #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif (qualConDeclToCon qcd) (toDerivClauses qns) -- 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!" 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 #if MIN_VERSION_template_haskell(2,11,0) toDec (Hs.TypeFamDecl _ h sig inj) = OpenTypeFamilyD $ TypeFamilyHead (toName h) (toTyVars h) (maybe NoSig KindSig . toMaybeKind $ sig) (fmap toInjectivityAnn inj) toDec (Hs.DataFamDecl _ _ h sig) = DataFamilyD (toName h) (toTyVars h) (toMaybeKind sig) #elif MIN_VERSION_haskell_src_exts(1,18,0) toDec (Hs.TypeFamDecl _ h sig inj) = FamilyD TypeFam (toName h) (toTyVars h) (toMaybeKind sig) toDec (Hs.DataFamDecl _ _ h sig) = FamilyD DataFam (toName h) (toTyVars h) (toMaybeKind sig) #else toDec (Hs.TypeFamDecl _ h k) = FamilyD TypeFam (toName h) (toTyVars h) (fmap toKind k) -- TODO: do something with context? toDec (Hs.DataFamDecl _ _ h k) = FamilyD DataFam (toName h) (toTyVars h) (fmap toKind k) #endif toDec a@(Hs.FunBind _ mtchs) = hsMatchesToFunD mtchs toDec (Hs.PatBind _ p rhs bnds) = ValD (toPat p) (hsRhsToBody rhs) (toDecs bnds) toDec i@(Hs.InstDecl _ (Just overlap) _ _) = noTH "toDec" (fmap (const ()) overlap, i) -- the 'vars' bit seems to be for: instance forall a. C (T a) where ... -- TH's own parser seems to flat-out ignore them, and honestly I can't see -- that it's obviously wrong to do so. #if MIN_VERSION_template_haskell(2,11,0) toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD Nothing (toCxt irule) (toType irule) (toDecs ids) #else toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD (toCxt irule) (toType irule) (toDecs ids) #endif toDec (Hs.ClassDecl _ cxt h fds decls) = ClassD (toCxt cxt) (toName h) (toTyVars h) (fmap toFunDep fds) (toDecs decls) where toFunDep (Hs.FunDep _ ls rs) = FunDep (fmap toName ls) (fmap toName rs) toDec x = todo "toDec" x #if MIN_VERSION_haskell_src_exts(1,18,0) instance ToMaybeKind (Hs.ResultSig l) where toMaybeKind (Hs.KindSig _ k) = Just $ toKind k toMaybeKind (Hs.TyVarSig _ _) = Nothing instance ToMaybeKind a => ToMaybeKind (Maybe a) where toMaybeKind Nothing = Nothing toMaybeKind (Just a) = toMaybeKind a #endif #if MIN_VERSION_template_haskell(2,11,0) instance ToInjectivityAnn (Hs.InjectivityInfo l) where toInjectivityAnn (Hs.InjectivityInfo _ n ns) = InjectivityAnn (toName n) (fmap toName ns) #endif transAct :: Maybe (Hs.Activation l) -> Phases transAct Nothing = AllPhases transAct (Just (Hs.ActiveFrom _ n)) = FromPhase n transAct (Just (Hs.ActiveUntil _ n)) = BeforePhase n instance ToName (Hs.DeclHead l) where toName (Hs.DHead _ n) = toName n toName (Hs.DHInfix _ _ n) = toName n toName (Hs.DHParen _ h) = toName h toName (Hs.DHApp _ h _) = toName h instance ToTyVars (Hs.DeclHead l) where toTyVars (Hs.DHead _ _) = [] toTyVars (Hs.DHParen _ h) = toTyVars h toTyVars (Hs.DHInfix _ tvb _) = [toTyVar tvb] toTyVars (Hs.DHApp _ h tvb) = toTyVars h ++ [toTyVar tvb] instance ToNames a => ToNames (Maybe a) where toNames Nothing = [] toNames (Just a) = toNames a instance ToNames (Hs.Deriving l) where #if MIN_VERSION_haskell_src_exts(1,20,0) toNames (Hs.Deriving _ _ irules) = #else toNames (Hs.Deriving _ irules) = #endif concatMap toNames irules instance ToNames (Hs.InstRule l) where toNames (Hs.IParen _ irule) = toNames irule toNames (Hs.IRule _ _mtvbs _mcxt mihd) = toNames mihd instance ToNames (Hs.InstHead l) where toNames (Hs.IHCon _ n) = [toName n] toNames (Hs.IHInfix _ _ n) = [toName n] toNames (Hs.IHParen _ h) = toNames h toNames (Hs.IHApp _ h _) = toNames h instance ToCxt (Hs.InstRule l) where toCxt (Hs.IRule _ _ cxt _) = toCxt cxt toCxt (Hs.IParen _ irule) = toCxt irule instance ToCxt (Hs.Context l) where toCxt x = case x of Hs.CxEmpty _ -> [] Hs.CxSingle _ x' -> [toPred x'] Hs.CxTuple _ xs -> fmap toPred xs instance ToCxt a => ToCxt (Maybe a) where toCxt Nothing = [] toCxt (Just a) = toCxt a instance ToType (Hs.InstRule l) where toType (Hs.IRule _ _ _ h) = toType h toType (Hs.IParen _ irule) = toType irule instance ToType (Hs.InstHead l) where toType (Hs.IHCon _ qn) = toType qn toType (Hs.IHInfix _ typ qn) = AppT (toType typ) (toType qn) toType (Hs.IHParen _ hd) = toType hd toType (Hs.IHApp _ hd typ) = AppT (toType hd) (toType typ) qualConDeclToCon :: Hs.QualConDecl l -> Con qualConDeclToCon (Hs.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (toTyVars ns) (toCxt cxt) (conDeclToCon cdecl) instance ToTyVars a => ToTyVars (Maybe a) where toTyVars Nothing = [] toTyVars (Just a) = toTyVars a instance ToTyVars a => ToTyVars [a] where toTyVars = concatMap toTyVars instance ToTyVars (Hs.TyVarBind l) where toTyVars tvb = [toTyVar tvb] instance ToType (Hs.QName l) where toType = ConT . toName conDeclToCon :: Hs.ConDecl l -> Con conDeclToCon (Hs.ConDecl _ n tys) = NormalC (toName n) (map toStrictType tys) conDeclToCon (Hs.RecDecl _ n fieldDecls) = RecC (toName n) (concatMap convField fieldDecls) where convField :: Hs.FieldDecl l -> [VarStrictType] convField (Hs.FieldDecl _ ns t) = let (strict, ty) = toStrictType t in map (\n' -> (toName n', strict, ty)) ns hsMatchesToFunD :: [Hs.Match l] -> Dec hsMatchesToFunD [] = FunD (mkName []) [] -- errorish hsMatchesToFunD xs@(Hs.Match _ n _ _ _ : _) = FunD (toName n) (fmap hsMatchToClause xs) hsMatchesToFunD xs@(Hs.InfixMatch _ _ n _ _ _ : _) = FunD (toName n) (fmap hsMatchToClause xs) hsMatchToClause :: Hs.Match l -> Clause hsMatchToClause (Hs.Match _ _ ps rhs bnds) = Clause (fmap toPat ps) (hsRhsToBody rhs) (toDecs bnds) hsMatchToClause (Hs.InfixMatch _ p _ ps rhs bnds) = Clause (fmap toPat (p:ps)) (hsRhsToBody rhs) (toDecs bnds) hsRhsToBody :: Hs.Rhs l -> 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 l -> 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 l -> Guard hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)] hsStmtToGuard (Hs.Qualifier _ e) = NormalG (toExp e) hsStmtToGuard (Hs.LetStmt _ bs) = PatG [LetS (toDecs bs)] ----------------------------------------------------------------------------- -- * ToDecs InstDecl instance ToDecs (Hs.InstDecl l) where toDecs (Hs.InsDecl _ decl) = toDecs decl toDecs d = todo "toDec" d -- * ToDecs HsDecl HsBinds instance ToDecs (Hs.Decl l) where toDecs a@(Hs.TypeSig _ ns t) = let xs = fmap (flip SigD (toType t) . toName) ns in xs toDecs (Hs.InfixDecl l assoc Nothing ops) = toDecs (Hs.InfixDecl l assoc (Just 9) ops) toDecs (Hs.InfixDecl _ assoc (Just 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 toDecs a = [toDec a] instance ToDecs a => ToDecs [a] where toDecs a = concatMap toDecs a ----------------------------------------------------------------------------- haskell-src-meta-0.8.2/src/Language/Haskell/Meta/Utils.hs0000644000000000000000000002675613435374604021313 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell, RankNTypes, StandaloneDeriving, DeriveDataTypeable, PatternGuards, FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-} -- | This module is a staging ground -- for to-be-organized-and-merged-nicely code. module Language.Haskell.Meta.Utils where import Data.List (findIndex) import Data.Typeable import Data.Generics hiding(Fixity) import Language.Haskell.Meta import System.IO.Unsafe(unsafePerformIO) import Language.Haskell.Exts.Pretty(prettyPrint) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr import Text.PrettyPrint import Control.Monad ----------------------------------------------------------------------------- cleanNames :: (Data a) => a -> a cleanNames = everywhere (mkT cleanName) where cleanName :: Name -> Name cleanName n | isNameU n = n | otherwise = (mkName . nameBase) n isNameU :: Name -> Bool isNameU (Name _ (NameU _)) = True isNameU _ = False -- | The type passed in must have a @Show@ instance which -- produces a valid Haskell expression. Returns an empty -- @String@ if this is not the case. This is not TH-specific, -- but useful in general. pretty :: (Show a) => a -> String pretty a = case parseHsExp (show a) of Left _ -> [] Right e -> prettyPrint e pp :: (Data a, Ppr a) => a -> String pp = pprint . cleanNames ppDoc :: (Data a, Ppr a) => a -> Doc ppDoc = text . pp gpretty :: (Data a) => a -> String gpretty = either (const []) prettyPrint . parseHsExp . gshow 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 #if !MIN_VERSION_th_orphans(0,12,0) #if MIN_VERSION_base(4,7,0) deriving instance Typeable Q #else deriving instance Typeable1 Q #endif deriving instance Typeable QuasiQuoter #endif -- | @unsafeRunQ = unsafePerformIO . runQ@ unsafeRunQ :: Q a -> a unsafeRunQ = unsafePerformIO . runQ nameToRawCodeStr :: Name -> String nameToRawCodeStr n = let s = showNameParens n in case nameSpaceOf n of Just VarName -> "'"++s Just DataName -> "'"++s Just TcClsName -> "''"++s _ -> concat ["(mkName \"", filter (/='"') s, "\")"] where showNameParens :: Name -> String showNameParens n = let nb = nameBase n in case nb of (c:_) | isSym c -> concat ["(",nb,")"] _ -> nb isSym :: Char -> Bool isSym = (`elem` ("><.\\/!@#$%^&*-+?:|" :: [Char])) ----------------------------------------------------------------------------- (|$|) :: ExpQ -> ExpQ -> ExpQ infixr 0 |$| f |$| x = [|$f $x|] (|.|) :: ExpQ -> ExpQ -> ExpQ infixr 9 |.| g |.| f = [|$g . $f|] (|->|) :: TypeQ -> TypeQ -> TypeQ infixr 9 |->| a |->| b = appT (appT arrowT a) b unForall :: Type -> Type unForall (ForallT _ _ t) = t unForall t = t functionT :: [TypeQ] -> TypeQ functionT = foldl1 (|->|) mkVarT :: String -> TypeQ mkVarT = varT . mkName -- | Infinite list of names composed of lowercase letters myNames :: [Name] myNames = let xs = fmap (:[]) ['a'..'z'] ys = iterate (join (zipWith (++))) xs in fmap mkName (concat ys) -- | Generalisation of renameTs renameThings _ env new acc [] = (reverse acc, env, new) renameThings f env new acc (t:ts) = let (t', env', new') = f env new t in renameThings f env' new' (t':acc) ts -- | renameT applied to a list of types renameTs :: [(Name, Name)] -> [Name] -> [Type] -> [Type] -> ([Type], [(Name,Name)], [Name]) renameTs = renameThings renameT -- | Rename type variables in the Type according to the given association -- list. Normalise constructor names (remove qualification, etc.) -- If a name is not found in the association list, replace it with one from -- the fresh names list, and add this translation to the returned list. -- The fresh names list should be infinite; myNames is a good example. renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name,Name)], [Name]) renameT env [] _ = error "renameT: ran out of names!" renameT env (x:new) (VarT n) | Just n' <- lookup n env = (VarT n',env,x:new) | otherwise = (VarT x, (n,x):env, new) renameT env new (ConT n) = (ConT (normaliseName n), env, new) renameT env new t@(TupleT {}) = (t,env,new) renameT env new ArrowT = (ArrowT,env,new) renameT env new ListT = (ListT,env,new) renameT env new (AppT t t') = let (s,env',new') = renameT env new t (s',env'',new'') = renameT env' new' t' in (AppT s s', env'', new'') renameT env new (ForallT ns cxt t) = let (ns',env2,new2) = renameTs env new [] (fmap (VarT . toName) ns) ns'' = fmap unVarT ns' (cxt',env3,new3) = renamePreds env2 new2 [] cxt (t',env4,new4) = renameT env3 new3 t in (ForallT ns'' cxt' t', env4, new4) where unVarT (VarT n) = PlainTV n renamePreds = renameThings renamePred #if MIN_VERSION_template_haskell(2,10,0) renamePred = renameT #else renamePred env new (ClassP n ts) = let (ts', env', new') = renameTs env new [] ts in (ClassP (normaliseName n) ts', env', new') renamePred env new (EqualP t1 t2) = let (t1', env1, new1) = renameT env new t1 (t2', env2, new2) = renameT env1 new1 t2 in (EqualP t1' t2', env2, new2) #endif -- | Remove qualification, etc. normaliseName :: Name -> Name normaliseName = mkName . nameBase applyT :: Type -> Type -> Type applyT (ForallT [] _ t) t' = t `AppT` t' applyT (ForallT (n:ns) cxt t) t' = ForallT ns cxt (substT [(toName n,t')] (fmap toName ns) t) applyT t t' = t `AppT` t' substT :: [(Name, Type)] -> [Name] -> Type -> Type substT env bnd (ForallT ns _ t) = substT env (fmap toName ns++bnd) t substT env bnd t@(VarT n) | n `elem` bnd = t | otherwise = maybe t id (lookup n env) substT env bnd (AppT t t') = AppT (substT env bnd t) (substT env bnd t') substT _ _ t = t splitCon :: Con -> (Name,[Type]) splitCon c = (conName c, conTypes c) strictTypeTy :: StrictType -> Type strictTypeTy (_,t) = t varStrictTypeTy :: VarStrictType -> Type varStrictTypeTy (_,_,t) = t conTypes :: Con -> [Type] conTypes (NormalC _ sts) = fmap strictTypeTy sts conTypes (RecC _ vts) = fmap varStrictTypeTy vts conTypes (InfixC t _ t') = fmap strictTypeTy [t,t'] conTypes (ForallC _ _ c) = conTypes c conToConType :: Type -> Con -> Type conToConType ofType con = foldr (\a b -> AppT (AppT ArrowT a) b) ofType (conTypes con) decCons :: Dec -> [Con] #if MIN_VERSION_template_haskell(2,11,0) decCons (DataD _ _ _ _ cons _) = cons decCons (NewtypeD _ _ _ _ con _) = [con] #else decCons (DataD _ _ _ cons _) = cons decCons (NewtypeD _ _ _ con _) = [con] #endif decCons _ = [] decTyVars :: Dec -> [TyVarBndr] #if MIN_VERSION_template_haskell(2,11,0) decTyVars (DataD _ _ ns _ _ _) = ns decTyVars (NewtypeD _ _ ns _ _ _) = ns #else decTyVars (DataD _ _ ns _ _) = ns decTyVars (NewtypeD _ _ ns _ _) = ns #endif decTyVars (TySynD _ ns _) = ns decTyVars (ClassD _ _ ns _ _) = ns decTyVars _ = [] decName :: Dec -> Maybe Name decName (FunD n _) = Just n #if MIN_VERSION_template_haskell(2,11,0) decName (DataD _ n _ _ _ _) = Just n decName (NewtypeD _ n _ _ _ _) = Just n #else decName (DataD _ n _ _ _) = Just n decName (NewtypeD _ n _ _ _) = Just n #endif decName (TySynD n _ _) = Just n decName (ClassD _ n _ _ _) = Just n decName (SigD n _) = Just n decName (ForeignD fgn) = Just (foreignName fgn) decName _ = Nothing foreignName :: Foreign -> Name foreignName (ImportF _ _ _ n _) = n foreignName (ExportF _ _ n _) = n unwindT :: Type -> [Type] unwindT = go where go :: Type -> [Type] go (ForallT _ _ t) = go t go (AppT (AppT ArrowT t) t') = t : go t' go _ = [] unwindE :: Exp -> [Exp] unwindE = go [] where go acc (e `AppE` e') = go (e':acc) e go acc e = e:acc -- | The arity of a Type. arityT :: Type -> Int arityT = go 0 where go :: Int -> Type -> Int go n (ForallT _ _ t) = go n t go n (AppT (AppT ArrowT _) t) = let n' = n+1 in n' `seq` go n' t go n _ = n typeToName :: Type -> Maybe Name typeToName t | ConT n <- t = Just n | ArrowT <- t = Just ''(->) | ListT <- t = Just ''[] | TupleT n <- t = Just $ tupleTypeName n | ForallT _ _ t' <- t = typeToName t' | otherwise = Nothing -- | Randomly useful. nameSpaceOf :: Name -> Maybe NameSpace nameSpaceOf (Name _ (NameG ns _ _)) = Just ns nameSpaceOf _ = Nothing conName :: Con -> Name conName (RecC n _) = n conName (NormalC n _) = n conName (InfixC _ n _) = n conName (ForallC _ _ con) = conName con recCName :: Con -> Maybe Name recCName (RecC n _) = Just n recCName _ = Nothing dataDCons :: Dec -> [Con] #if MIN_VERSION_template_haskell(2,11,0) dataDCons (DataD _ _ _ _ cons _) = cons #else dataDCons (DataD _ _ _ cons _) = cons #endif dataDCons _ = [] fromDataConI :: Info -> Q (Maybe Exp) #if MIN_VERSION_template_haskell(2,11,0) fromDataConI (DataConI dConN ty tyConN) = #else fromDataConI (DataConI dConN ty tyConN fxty) = #endif let n = arityT ty in replicateM n (newName "a") >>= \ns -> return (Just (LamE [ConP dConN (fmap VarP ns)] (TupE $ fmap VarE ns))) fromDataConI _ = return Nothing fromTyConI :: Info -> Maybe Dec fromTyConI (TyConI dec) = Just dec fromTyConI _ = Nothing mkFunD :: Name -> [Pat] -> Exp -> Dec mkFunD f xs e = FunD f [Clause xs (NormalB e) []] mkClauseQ :: [PatQ] -> ExpQ -> ClauseQ mkClauseQ ps e = clause ps (normalB e) [] ----------------------------------------------------------------------------- -- | The strategy for producing QuasiQuoters which -- this datatype aims to facilitate is as follows. -- Given a collection of datatypes which make up -- the to-be-quasiquoted languages AST, make each -- type in this collection an instance of at least -- @Show@ and @Lift@. Now, assuming @parsePat@ and -- @parseExp@, both of type @String -> Q a@ (where @a@ -- is the top level type of the AST), are the pair of -- functions you wish to use for parsing in pattern and -- expression context respectively, put them inside -- a @Quoter@ datatype and pass this to quasify. {- data Quoter a = Quoter { expQ :: (Lift a) => String -> Q a , patQ :: (Show a) => String -> Q a } quasify :: (Show a, Lift a) => Quoter a -> QuasiQuoter quasify q = QuasiQuoter (toExpQ (expQ q)) (toPatQ (patQ q)) -} toExpQ :: (Lift a) => (String -> Q a) -> (String -> ExpQ) toExpQ parseQ = (lift =<<) . parseQ toPatQ :: (Show a) => (String -> Q a) -> (String -> PatQ) toPatQ parseQ = (showToPatQ =<<) . parseQ showToPatQ :: (Show a) => a -> PatQ showToPatQ = either fail return . parsePat . show ----------------------------------------------------------------------------- eitherQ :: (e -> String) -> Either e a -> Q a eitherQ toStr = either (fail . toStr) return ----------------------------------------------------------------------------- normalizeT :: (Data a) => a -> a normalizeT = everywhere (mkT go) where go :: Type -> Type go (ConT n) | n == ''[] = ListT go (AppT (TupleT 1) t) = t go (ConT n) | Just m <- findIndex (== n) tupleNames = TupleT (m + 2) where tupleNames = map tupleTypeName [2 .. 64] go t = t ----------------------------------------------------------------------------- haskell-src-meta-0.8.2/tests/TestExamples.hs0000644000000000000000000000221413432623226017161 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} import Control.Monad (when) import qualified BF import qualified Hs import qualified HsHere import qualified SKI import SKI (SKI(S, K, I, (:$))) -- Very dumb test framework shouldBe :: (Show a, Eq a) => a -> a -> IO () actual `shouldBe` expected = case actual == expected of True -> return () False -> do putStr "Expected: " print expected putStr "Actual: " print actual fail "Expectation failure" a :: Int -> String a x = [HsHere.here| random "text" $(x + 1) something else|] hereTest :: IO () hereTest = do a 3 `shouldBe` (" random \"text\" "++ show (3 + 1) ++"\n something else") -- TODO: better test exercising the bf quasiquoter bfTest :: IO () bfTest = do BF.eval_ (BF.parse BF.bfHelloWorld) "" `shouldBe` "Hello World!\n" hsTest :: IO () hsTest = do (\ [Hs.hs|a@(x,_)|] -> [Hs.hs|(a,x)|]) (42,88) `shouldBe` ((42,88),42) -- TODO: better test exercising the ski quasiquoter skiTest :: IO () skiTest = do SKI.parse "S(SS)IK(SK)" `shouldBe` ([(((S :$ (S :$ S)) :$ I) :$ K) :$ (S :$ K)],"") main :: IO () main = do putStrLn "" hereTest bfTest hsTest skiTest haskell-src-meta-0.8.2/examples/BF.hs0000644000000000000000000001222313432616200015501 0ustar0000000000000000{-# LANGUAGE BangPatterns, TemplateHaskell #-} module BF ( bf,bf2,bfHelloWorld,eval_,parse ) where import Language.Haskell.Meta (parsePat) import Language.Haskell.TH.Lib import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Data.Char import Data.IntMap(IntMap) import qualified Data.IntMap as IM bf :: QuasiQuoter bf = QuasiQuoter { quoteExp = bfExpQ, quotePat = bfPatQ } bf2 :: QuasiQuoter bf2 = QuasiQuoter { quoteExp = bf2ExpQ, quotePat = bfPatQ } bf2ExpQ :: String -> ExpQ bf2ExpQ s = [|eval (parse s)|] bfExpQ :: String -> ExpQ bfExpQ s = [|eval_ (parse s)|] bfPatQ :: String -> PatQ bfPatQ s = do let p = (parsePat . show . parse) s case p of Left e -> fail e Right p -> return p instance Lift Bf where lift Inp = [|Inp|] lift Out = [|Out|] lift Inc = [|Inc|] lift Dec = [|Dec|] lift MovL = [|MovL|] lift MovR = [|MovR|] lift (While xs) = [|While $(lift xs)|] type Ptr = Int newtype Mem = Mem (IntMap Int) deriving (Show) data Bf = Inp | Out | Inc | Dec | MovL | MovR | While [Bf] deriving (Eq,Ord,Read,Show) data Status = D Ptr Mem | W Int Status | R (Int -> Status) -- ghci> exec (parse helloWorld) -- Hello World! -- (4,Mem (fromList [(0,0),(1,87),(2,100),(3,33),(4,10)])) bfHelloWorld :: String bfHelloWorld = "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>." eval_ :: [Bf] -> (String -> String) eval_ is = go (run 0 initMem is) where go (D p m) _ = [] go (W n s) cs = chr n : go s cs go (R cont) [] = "*** Exception: bf blocked on input" go (R cont) (c:cs) = go ((cont . ord) c) cs eval :: [Bf] -> String -> (String, (Ptr, Mem)) eval is = go [] (run 0 initMem is) where go acc (D p m) _ = (reverse acc, (p, m)) go acc (W n s) cs = go (chr n:acc) s cs go _ (R cont) [] = ("*** Exception: bf blocked on input",(-1, Mem IM.empty)) go acc (R cont) (c:cs) = go acc ((cont . ord) c) cs exec :: [Bf] -> IO (Ptr, Mem) exec is = go (run 0 initMem is) where go (D p m) = return (p, m) go (W n s) = putChar (chr n) >> go s go (R cont) = go . cont . ord =<< getChar run :: Ptr -> Mem -> [Bf] -> Status run dp m is = step dp m is (\dp m -> D dp m) step :: Ptr -> Mem -> [Bf] -> (Ptr -> Mem -> Status) -> Status step dp m [] k = k dp m step dp m (Inc:is) k = step dp (inc dp m) is k step dp m (Dec:is) k = step dp (dec dp m) is k step dp m (MovL:is) k = step (dp-1) m is k step dp m (MovR:is) k = step (dp+1) m is k step dp m (Inp:is) k = R (\c -> step dp (wr m dp c) is k) step dp m (Out:is) k = W (rd m dp) (step dp m is k) step dp m (While xs:is) k = let go dp m = if rd m dp == 0 then step dp m is k else step dp m xs go in go dp m initMem :: Mem initMem = Mem IM.empty inc :: Ptr -> (Mem -> Mem) dec :: Ptr -> (Mem -> Mem) rd :: Mem -> Ptr -> Int wr :: Mem -> Ptr -> Int -> Mem upd :: Mem -> Ptr -> (Int -> Int) -> Mem inc p m = upd m p (+1) dec p m = upd m p (subtract 1) rd (Mem m) p = maybe 0 id (IM.lookup p m) wr (Mem m) p n = Mem (IM.insert p n m) upd m p f = wr m p (f (rd m p)) parse :: String -> [Bf] parse s = go 0 [] s (\_ xs _ -> xs) where go :: Int -> [Bf] -> String -> (Int -> [Bf] -> String -> o) -> o go !n acc [] k = k n (reverse acc) [] go !n acc (',':cs) k = go (n+1) (Inp:acc) cs k go !n acc ('.':cs) k = go (n+1) (Out:acc) cs k go !n acc ('+':cs) k = go (n+1) (Inc:acc) cs k go !n acc ('-':cs) k = go (n+1) (Dec:acc) cs k go !n acc ('<':cs) k = go (n+1) (MovL:acc) cs k go !n acc ('>':cs) k = go (n+1) (MovR:acc) cs k go !n acc ('[':cs) k = go (n+1) [] cs (\n xs cs -> go n (While xs:acc) cs k) go !n acc (']':cs) k = k (n+1) (reverse acc) cs go !n acc (c :cs) k = go n acc cs k test0 = do a <- readFile "prime.bf" return (parse a) {- data Bf = Inp | Out | Inc | Dec | MovL | MovR | While [Bf] | Error String deriving (Eq,Ord,Read,Show) parse :: String -> [Bf] parse s = let p n s = case go n [] s of (_,xs,[]) -> xs (n,xs, s) -> xs ++ p n s in p 0 s where go :: Int -> [Bf] -> [Char] -> (Int, [Bf], String) go !n acc [] = (n, reverse acc, []) go !n acc (',':cs) = go (n+1) (Inp:acc) cs go !n acc ('.':cs) = go (n+1) (Out:acc) cs go !n acc ('+':cs) = go (n+1) (Inc:acc) cs go !n acc ('-':cs) = go (n+1) (Dec:acc) cs go !n acc ('<':cs) = go (n+1) (MovL:acc) cs go !n acc ('>':cs) = go (n+1) (MovR:acc) cs go !n acc ('[':cs) = case go (n+1) [] cs of (n,xs,cs) -> go n (While xs:acc) cs go !n acc (']':cs) = (n+1, reverse acc, cs) go !n acc (c :cs) = (n+1, [Error ("go error: char "++show n ++" illegal character: "++show c)], []) -} haskell-src-meta-0.8.2/examples/Hs.hs0000644000000000000000000000150313432617742015577 0ustar0000000000000000 -- | Eat your face! module Hs (hs, pat) where import Language.Haskell.Meta (parseExp, parsePat) import Language.Haskell.Meta.Utils (pretty) import Language.Haskell.TH.Lib import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax -- | -- > ghci> [$hs|\x -> (x,x)|] 42 -- > (42,42) -- > ghci> (\[$hs|a@(x,_)|] -> (a,x)) (42,88) -- > ((42,88),42) hs :: QuasiQuoter hs = QuasiQuoter { quoteExp = either fail transformE . parseExp , quotePat = either fail transformP . parsePat } transformE :: Exp -> ExpQ transformE = return transformP :: Pat -> PatQ transformP = return pat :: QuasiQuoter pat = QuasiQuoter { quoteExp = quoteExp hs , quotePat = \s -> case parseExp s of Left err -> fail err Right e -> either fail return (parsePat . pretty $ e) } haskell-src-meta-0.8.2/examples/HsHere.hs0000644000000000000000000000642613432615054016406 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-} module HsHere (here) where import Language.Haskell.Meta (parseExp, parsePat) import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Language.Haskell.Meta.Utils (cleanNames) import Text.ParserCombinators.ReadP import Data.Typeable(Typeable) import Data.Generics(Data) data Here = CodeH Exp | TextH String | ManyH [Here] deriving (Eq,Show,Data,Typeable) -- | Example: -- -- > a x = [here| random "text" $(x + 1) -- > something else|] -- -- Is like: -- -- > a x = " random \"text\" "++ show (x + 1) ++"\n something else" here :: QuasiQuoter here = QuasiQuoter {quoteType = fail "The here quoter is only for expressions and patterns" ,quoteDec = fail "The here quoter is only for expressions and patterns" ,quoteExp = hereExpQ ,quotePat = herePatQ} instance Lift Here where lift = liftHere liftHere :: Here -> ExpQ liftHere (TextH s) = (litE . stringL) s liftHere (CodeH e) = [|show $(return e)|] liftHere (ManyH hs) = [|concat $(listE (fmap liftHere hs))|] hereExpQ :: String -> ExpQ hereExpQ s = case run s of [] -> fail "here: parse error" e:_ -> lift (cleanNames e) herePatQ :: String -> PatQ herePatQ s = do e <- hereExpQ s let p = (parsePat . pprint . cleanNames) e case p of Left e -> fail e Right p -> return p run :: String -> [Here] run = fst . parse parse :: String -> ([Here], String) parse = runP hereP hereP :: ReadP Here hereP = (ManyH . mergeTexts) `fmap` many (oneP =<< look) mergeTexts :: [Here] -> [Here] mergeTexts [] = [] mergeTexts (TextH s:TextH t:hs) = mergeTexts (TextH (s++t):hs) mergeTexts (h:hs) = h : mergeTexts hs oneP :: String -> ReadP Here oneP s | [] <- s = pfail | '\\':'$':s <- s = do skip 2 (TextH . ("\\$"++)) `fmap` munch (/='\\') | '$':'(':s <- s = skip 2 >> go 1 [] s | c:s <- s = do skip 1 (TextH . (c:)) `fmap` munch (not.(`elem`"\\$")) where go _ acc [] = return (TextH (reverse acc)) go 1 [] (')':_) = skip 1 >> return (TextH "$()") go 1 acc (')':_) = do skip (1 + length acc) let s = reverse acc either (const (return (TextH s))) (return . CodeH) (parseExp s) go n acc ('(':s) = go (n+1) ('(':acc) s go n acc (')':s) = go (n-1) (')':acc) s go n acc (c:s) = go n (c:acc) s runP :: ReadP a -> String -> ([a], String) runP p s = case readP_to_S p s of [] -> ([],[]) xs -> mapfst (:[]) (last xs) where mapfst f (a,b) = (f a,b) skip :: Int -> ReadP () skip n = count n get >> return () lexemeP :: ReadP a -> ReadP a lexemeP p = p >>= \x -> skipSpaces >> return x nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a) nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p) parensP = between oparenP cparenP bracksP = between oparenP cparenP oparenP = char '(' cparenP = char ')' obrackP = char '[' cbrackP = char ']' haskell-src-meta-0.8.2/examples/SKI.hs0000644000000000000000000001044313432620647015654 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-} module SKI (SKI(..),ski,parse) where import Language.Haskell.Meta (parseExp, parsePat) import Language.Haskell.TH.Lib hiding (parensP) import Language.Haskell.TH.Ppr import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Language.Haskell.Meta.Utils (cleanNames, ppDoc, unsafeRunQ) import Text.ParserCombinators.ReadP import Data.Typeable(Typeable) import Data.Generics(Data) import Text.PrettyPrint(render) data SKI = S | K | I | E Exp | SKI :$ SKI deriving (Eq,Data,Typeable) run :: String -> [SKI] run = fmap eval . fst . parse -- I x = x -- K x y = x -- S x y z = (x z) (y z) eval :: SKI -> SKI eval (I :$ x) = eval x eval ((K :$ x) :$ y) = eval x eval (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z)) eval (E e :$ E e') = E (unsafeRunQ[|$(return e) $(return e')|]) eval (x :$ y) = eval0 ((eval x) :$ (eval y)) eval x = x eval0 (I :$ x) = eval x eval0 ((K :$ x) :$ y) = eval x eval0 (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z)) eval0 (E e :$ E e') = E (unsafeRunQ[|$(return e) $(return e')|]) eval0 x = x ski :: QuasiQuoter ski = QuasiQuoter {quoteExp = skiExpQ ,quotePat = skiPatQ} instance Lift SKI where lift = liftSKI liftSKI (E e) = return e liftSKI a = go a where go S = [|S|] go K = [|K|] go I = [|I|] go (E e) = [|E e|] go (x:$y) = [|$(go x) :$ $(go y)|] instance Show SKI where showsPrec p (S) = showString "S" showsPrec p (K) = showString "K" showsPrec p (I) = showString "I" showsPrec p (E x1) = showParen (p > 10) (showString (render (ppDoc x1))) showsPrec p ((:$) x1 x2) = showParen (p > 10) (showsPrec 11 x1 . (showString " :$ " . showsPrec 10 x2)) skiExpQ :: String -> ExpQ skiExpQ s = case run s of [] -> fail "ski: parse error" e:_ -> lift (cleanNames e) skiPatQ :: String -> PatQ skiPatQ s = do e <- skiExpQ s let p = (parsePat . pprint . cleanNames) e case p of Left e -> fail e Right p -> return p -- ghci> parse "S(SS)IK(SK)" -- ([(((S :$ (S :$ S)) :$ I) :$ K) :$ (S :$ K)],"") parse :: String -> ([SKI], String) parse = runP skiP skiP :: ReadP SKI skiP = nestedP parensP (let go a = (do b <- lexemeP (oneP <++ skiP) go (a:$b)) <++ return a in lexemeP (go =<< lexemeP oneP)) oneP :: ReadP SKI oneP = nestedP parensP (lexemeP (choice [sP ,kP ,iP ,spliceP =<< look ])) spliceP :: String -> ReadP SKI spliceP s | '[':s <- s = skip 1 >> go 1 [] s | otherwise = pfail where go _ _ [] = pfail go 1 acc (']':_) = do skip (1 + length acc) either (const pfail) (return . E) (parseExp (reverse acc)) go n acc ('[':s) = go (n+1) ('[':acc) s go n acc (']':s) = go (n-1) (']':acc) s go n acc (c:s) = go n (c:acc) s sP = (char 's' +++ char 'S') >> return S kP = (char 'k' +++ char 'K') >> return K iP = (char 'i' +++ char 'I') >> return I runP :: ReadP a -> String -> ([a], String) runP p s = case readP_to_S p s of [] -> ([],[]) xs -> mapfst (:[]) (last xs) where mapfst f (a,b) = (f a,b) skip :: Int -> ReadP () skip n = count n get >> return () lexemeP :: ReadP a -> ReadP a lexemeP p = p >>= \x -> skipSpaces >> return x nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a) nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p) parensP = between oparenP cparenP bracksP = between oparenP cparenP oparenP = char '(' cparenP = char ')' obrackP = char '[' cbrackP = char ']' {- import Prelude hiding (($)) data Komb = S (Maybe (Komb, Maybe Komb)) | K (Maybe Komb) deriving Show S Nothing $ x = S (Just (x, Nothing)) S (Just (x, Nothing)) $ y = S (Just (x, Just y)) S (Just (x, Just y)) $ z = x $ z $ (y $ z) K Nothing $ x = K (Just x) K (Just x) $ y = y q x = x $ (c $ k) $ k $ k $ s where s = S Nothing k = K Nothing c = s $ (b $ b $ s) $ k $ k b = s $ (k $ s) $ k -} haskell-src-meta-0.8.2/tests/Splices.hs0000644000000000000000000000415313435374604016157 0ustar0000000000000000{-# LANGUAGE CPP, TemplateHaskell #-} -- | Tests stuff mostly by just compiling correctly import qualified Language.Haskell.Exts.Extension as Extension import qualified Language.Haskell.Exts.Parser as Parser import qualified Language.Haskell.Meta as Meta ----- Testing names ----- -- Test that the unit constructor works $(either error return $ Meta.parseDecs "unit :: IO ()\nunit = return ()") -- Testing that the [] constructor works in types, #if MIN_VERSION_base(4,9,0) $(either error return $ Meta.parseDecs "nilp :: [a] -> ([] a)\nnilp [] = []") #else -- CPP Note: Apparently ghc < 7 doesn't parse this correctly w/o the forall. -- https://github.com/DanBurton/haskell-src-meta/issues/2 $(either error return $ Meta.parseDecs "nilp :: forall a. [a] -> ([] a)\nnilp [] = []") #endif $(either error return $ Meta.parseDecs "pair :: (,) Int Int\npair = (,) 1 2") ----- Testing classes and instances ----- #if MIN_VERSION_base(4,9,0) $(either error return $ Meta.parseDecs $ unlines ["class MyClass a where mymethod :: a -> b -> (a,b)" ,"instance MyClass Bool where mymethod a b = (a,b)" ]) #else -- CPP Note: Apparently ghc < 7 doesn't parse this correctly w/o the forall. -- https://github.com/DanBurton/haskell-src-meta/issues/2 $(either error return $ Meta.parseDecs $ unlines ["class MyClass a where mymethod :: forall b. a -> b -> (a,b)" ,"instance MyClass Bool where mymethod a b = (a,b)" ]) #endif #if MIN_VERSION_template_haskell(2,12,0) $(either error return $ Meta.parseDecsWithMode (Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.TypeApplications] }) $ unlines ["tenStr :: String" ,"tenStr = show @Int 10"]) #else -- Type Application not supported by template-haskell < 2.12 $(either error return $ Meta.parseDecs $ unlines ["tenStr :: String" ,"tenStr = show (10 :: Int)"]) #endif -- Just to check that it works as intended main = do -9 <- return $(either error return $ Meta.parseExp "-3^2") :: IO Int () <- unit [] <- return (nilp []) (1,2) <- return pair (True,1) <- return $ mymethod True 1 "10" <- return tenStr return () haskell-src-meta-0.8.2/tests/Main.hs0000644000000000000000000000300213435374604015431 0ustar0000000000000000{-# LANGUAGE CPP #-} module Main where import Language.Haskell.Meta.Parse import qualified Language.Haskell.Exts as Exts import qualified Language.Haskell.Exts.Extension as Extension import qualified Language.Haskell.Exts.Parser as Parser import qualified Language.Haskell.TH as TH import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit (Assertion, (@?=)) main :: IO () main = defaultMain tests tests :: [Test] tests = [ derivingClausesTest #if MIN_VERSION_template_haskell(2,12,0) , typeAppTest #endif ] derivingClausesTest :: Test derivingClausesTest = testCase "Deriving clauses preserved" $ roundTripDecls "data Foo = Foo deriving (A, B, C)" typeAppMode :: Exts.ParseMode typeAppMode = Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.TypeApplications] } typeAppTest :: Test typeAppTest = testCase "Type app preserved" $ roundTripDeclsWithMode typeAppMode "tenStr = show @Int 10" roundTripDecls :: String -> Assertion roundTripDecls s = do declsExts <- liftEither $ parseHsDecls s declsExts' <- liftEither $ parseDecs s >>= parseHsDecls . TH.pprint declsExts' @?= declsExts roundTripDeclsWithMode :: Exts.ParseMode -> String -> Assertion roundTripDeclsWithMode mode s = do declsExts <- liftEither $ parseHsDeclsWithMode mode s declsExts' <- liftEither $ parseDecsWithMode mode s >>= parseHsDeclsWithMode mode . TH.pprint declsExts' @?= declsExts liftEither :: Monad m => Either String a -> m a liftEither = either fail return haskell-src-meta-0.8.2/LICENSE0000644000000000000000000001744013432550531014057 0ustar0000000000000000----------------------------------------------------------------------------- ----------------------------------------------------------------------------- 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. ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- th-lift Copyright (c) Ian Lynagh. 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. ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- haskell-src-exts This library (Haskell Source eXtensions) is derived from code from several sources: * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). The full text of these licenses is reproduced below. All of the licenses are BSD-style or compatible. ----------------------------------------------------------------------------- The haskell-src-exts package itself is distributable under the modified BSD license: Copyright (c) 2005, Niklas Broberg All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * 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. * The names of its contributors may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT OWNER 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. ----------------------------------------------------------------------------- The Glasgow Haskell Compiler License Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - 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. - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE 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 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. ----------------------------------------------------------------------------- Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: Copyright (c) 2002 Simon Peyton Jones The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, including this Notice. Modified versions of this Report may also be copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. ----------------------------------------------------------------------------- haskell-src-meta-0.8.2/Setup.lhs0000644000000000000000000000010113432550531014644 0ustar0000000000000000> import Distribution.Simple > main :: IO () > main = defaultMainhaskell-src-meta-0.8.2/haskell-src-meta.cabal0000644000000000000000000000454213435376412017200 0ustar0000000000000000name: haskell-src-meta version: 0.8.2 cabal-version: >= 1.8 build-type: Simple license: BSD3 license-file: LICENSE category: Language, Template Haskell author: Matt Morrow copyright: (c) Matt Morrow maintainer: danburton.email@gmail.com bug-reports: https://github.com/DanBurton/haskell-src-meta/issues tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 synopsis: Parse source to template-haskell abstract syntax. description: The translation from haskell-src-exts abstract syntax to template-haskell abstract syntax isn't 100% complete yet. extra-source-files: ChangeLog README.md library build-depends: base >= 4.6 && < 5, haskell-src-exts >= 1.18 && < 1.22, pretty >= 1.0 && < 1.2, syb >= 0.1 && < 0.8, template-haskell >= 2.8 && < 2.15, th-orphans >= 0.9.1 && < 0.14 if impl(ghc < 7.8) build-depends: safe <= 0.3.9 hs-source-dirs: src exposed-modules: Language.Haskell.Meta Language.Haskell.Meta.Parse Language.Haskell.Meta.Syntax.Translate Language.Haskell.Meta.Utils test-suite unit type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Main.hs build-depends: HUnit >= 1.2 && < 1.7, base >= 4.5 && < 5, haskell-src-exts >= 1.17 && < 1.22, haskell-src-meta, pretty >= 1.0 && < 1.2, template-haskell >= 2.7 && < 2.15, test-framework >= 0.8 && < 0.9, test-framework-hunit >= 0.3 && < 0.4 test-suite splices type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Splices.hs build-depends: base, haskell-src-exts, haskell-src-meta, template-haskell test-suite examples type: exitcode-stdio-1.0 hs-source-dirs: examples, tests main-is: TestExamples.hs build-depends: base, containers, haskell-src-meta, pretty, syb, template-haskell other-modules: BF, Hs, HsHere, SKI source-repository head type: git location: git://github.com/danburton/haskell-src-meta.git haskell-src-meta-0.8.2/ChangeLog0000644000000000000000000000767113435376636014650 0ustar00000000000000000.8.2: - Added ToExp implementation for type application - Added parseDecsWithMode and parseHsDeclsWithMode 0.8.1: - Compatible with GHC 8.6, haskell-src-exts 1.22 0.8.0.1: - Bump base and template-haskell library to versions shipped with GHC 7.6. 0.8: - Compatibility with GHC 8.2. - Remove deprecated modules. 0.7.0.1: - Fixed a bug that caused deriving clauses to be ignored on TH 2.11. 0.7.0: - Compatibility with haskell-src-exts 1.18. - Support dropped for GHC < 7.6 and haskell-src-exts < 1.17. 0.6.0.14: - Compatibility with GHC 8.0. 0.6.0.13: - Compatibility with GHC HEAD, haskell-src-exts 1.17 - Remove hsBindsToDecs, since it was redundant with toDecs. Technically this requires a minor-version bump, but I doubt anyone was using it. 0.6.0.12: - Support th-orphans 0.13 0.6.0.11: - Support syb 0.6 0.6.0.10: - Support syb 0.5, th-orphans 0.12 0.6.0.9: - Compatibility with GHC 7.10 - Update th-orphans dependency - Drop GHC < 7.4 support (actually it was already broken, since HSE 1.16 requires base >= 4.5) 0.6.0.8: - Move to HSE 1.16 0.6.0.7: - Fix compilation oops 0.6.0.6: - Move to HSE 1.15, adding support for multiway if 0.6.0.5: - Update th-orphans dependency 0.6.0.4: - Drop support for GHC 6.12 - Move to HSE 1.14 0.6.0.3: - Update th-orphans dependency - Some dependency loosening in anticipation of GHC 7.8 0.6.0.2: - Update syb dependency 0.6.0.1: - Fix haddock parse error 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.2: - More sensible determination of TH version available 0.5.1.1: - View pattern support, thanks to Nicolas Frisby. 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.3: - Support for GHC 7.4, thanks to Reiner Pope - Support for unresolved infix expressions, again thanks to Reiner Pope 0.5.0.2: - Fixed bug in translation of tuple constructors 0.5.0.1: - Added support for primitive string literals (Only in TH >= 2.5) 0.5: - Added support for instance declarations 0.4.0.2: - Compatibility with GHC 7.2 0.4.0.1: - Deprecate myDefaultParseMode and myDefaultExtensions in L.H.M.Parse 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.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.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.1: - Add support for inline pragmas, and improve support for type signatures (patch by Jonas Duregard) 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) 0.0.6: - last version released by Matt Morrow before his disappearance haskell-src-meta-0.8.2/README.md0000644000000000000000000000173113432664744014341 0ustar0000000000000000The `haskell-src-meta` Package [![Hackage](https://img.shields.io/hackage/v/haskell-src-meta.svg)](https://hackage.haskell.org/package/haskell-src-meta) [![Build Status](https://travis-ci.org/DanBurton/haskell-src-meta.svg)](https://travis-ci.org/DanBurton/haskell-src-meta) ================== `haskell-src-meta` is a package originally by Matt Morrow for converting a parsed AST from `haskell-src-exts` to a TH AST for use in splices and quasiquoters. The last version Matt released before he disappeared from the Haskell community was 0.0.6, but by that time his library was already popular, so some community members eventually decided to take over maintenance of the package, keeping it up to date with the latest versions of TH etc. 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. The above was written by Ben Millwood, but I (Dan Burton) share the same sentiment.