haskell-src-meta-0.8.5/examples/0000755000000000000000000000000013566633427014703 5ustar0000000000000000haskell-src-meta-0.8.5/src/0000755000000000000000000000000013436621420013636 5ustar0000000000000000haskell-src-meta-0.8.5/src/Language/0000755000000000000000000000000013436621420015361 5ustar0000000000000000haskell-src-meta-0.8.5/src/Language/Haskell/0000755000000000000000000000000013436621420016744 5ustar0000000000000000haskell-src-meta-0.8.5/src/Language/Haskell/Meta/0000755000000000000000000000000013566633427017650 5ustar0000000000000000haskell-src-meta-0.8.5/src/Language/Haskell/Meta/Syntax/0000755000000000000000000000000013566633427021136 5ustar0000000000000000haskell-src-meta-0.8.5/tests/0000755000000000000000000000000013557212603014214 5ustar0000000000000000haskell-src-meta-0.8.5/src/Language/Haskell/Meta.hs0000644000000000000000000000074313436621420020172 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.5/src/Language/Haskell/Meta/Parse.hs0000644000000000000000000001153213534313562021246 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.Exts.Extension import Language.Haskell.Exts.Parser hiding (parseExp, parsePat, parseType) import Language.Haskell.Exts.Pretty import qualified Language.Haskell.Exts.SrcLoc as Hs import qualified Language.Haskell.Exts.Syntax as Hs import Language.Haskell.Meta.Syntax.Translate ----------------------------------------------------------------------------- -- * 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 moduleDecls m = todo "" m -- TODO -- (Hs.XmlPage _ _ _ _ _ _ _) -- (Hs.XmlHybrid _ _ _ _ _ _ _ _ _) -- 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.SrcSpanInfo 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.5/src/Language/Haskell/Meta/Syntax/Translate.hs0000644000000000000000000007654713566633427023452 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {- | 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 qualified Data.Char as Char import qualified Data.List as List import qualified Language.Haskell.Exts.SrcLoc as Exts.SrcLoc import qualified Language.Haskell.Exts.Syntax as Exts import qualified Language.Haskell.TH.Syntax as TH ----------------------------------------------------------------------------- class ToName a where toName :: a -> TH.Name class ToNames a where toNames :: a -> [TH.Name] class ToLit a where toLit :: a -> TH.Lit class ToType a where toType :: a -> TH.Type class ToPat a where toPat :: a -> TH.Pat class ToExp a where toExp :: a -> TH.Exp class ToDecs a where toDecs :: a -> [TH.Dec] class ToDec a where toDec :: a -> TH.Dec class ToStmt a where toStmt :: a -> TH.Stmt class ToLoc a where toLoc :: a -> TH.Loc class ToCxt a where toCxt :: a -> TH.Cxt class ToPred a where toPred :: a -> TH.Pred class ToTyVars a where toTyVars :: a -> [TH.TyVarBndr] class ToMaybeKind a where toMaybeKind :: a -> Maybe TH.Kind #if MIN_VERSION_template_haskell(2,11,0) class ToInjectivityAnn a where toInjectivityAnn :: a -> TH.InjectivityAnn #endif #if MIN_VERSION_template_haskell(2,12,0) type DerivClause = TH.DerivClause #elif MIN_VERSION_template_haskell(2,11,0) type DerivClause = TH.Pred #else type DerivClause = TH.Name #endif class ToDerivClauses a where toDerivClauses :: a -> [DerivClause] -- for error messages moduleName :: String 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)] #if MIN_VERSION_template_haskell(2,16,0) toTupEl :: ToExp a => a -> Maybe TH.Exp toTupEl = Just . toExp #else toTupEl :: ToExp a => a -> TH.Exp toTupEl = toExp #endif ----------------------------------------------------------------------------- instance ToExp TH.Lit where toExp = TH.LitE instance (ToExp a) => ToExp [a] where toExp = TH.ListE . fmap toExp instance (ToExp a, ToExp b) => ToExp (a,b) where toExp (a,b) = TH.TupE [toTupEl a, toTupEl b] instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where toExp (a,b,c) = TH.TupE [toTupEl a, toTupEl b, toTupEl c] instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where toExp (a,b,c,d) = TH.TupE [toTupEl a, toTupEl b, toTupEl c, toTupEl d] instance ToPat TH.Lit where toPat = TH.LitP instance (ToPat a) => ToPat [a] where toPat = TH.ListP . fmap toPat instance (ToPat a, ToPat b) => ToPat (a,b) where toPat (a,b) = TH.TupP [toPat a, toPat b] instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where toPat (a,b,c) = TH.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) = TH.TupP [toPat a, toPat b, toPat c, toPat d] instance ToLit Char where toLit = TH.CharL instance ToLit String where toLit = TH.StringL instance ToLit Integer where toLit = TH.IntegerL instance ToLit Int where toLit = TH.IntegerL . toInteger instance ToLit Float where toLit = TH.RationalL . toRational instance ToLit Double where toLit = TH.RationalL . toRational ----------------------------------------------------------------------------- -- * ToName {String,HsName,Module,HsSpecialCon,HsQName} instance ToName String where toName = TH.mkName instance ToName (Exts.Name l) where toName (Exts.Ident _ s) = toName s toName (Exts.Symbol _ s) = toName s instance ToName (Exts.SpecialCon l) where toName (Exts.UnitCon _) = TH.mkName "()" -- TODO LumiGuide: '() toName (Exts.ListCon _) = ''[] -- Parser only uses this in types -- TODO LumiGuide: '[] toName (Exts.FunCon _) = ''(->) toName (Exts.TupleCon _ _ n) = TH.mkName $ concat ["(",replicate (n-1) ',',")"] -- TODO LumiGuide: -- . -- .| n<2 = '() -- .| otherwise = -- . let x = maybe [] (++".") (nameModule '(,)) -- . in TH.mkName . concat $ x : ["(",replicate (n-1) ',',")"] toName (Exts.Cons _) = '(:) toName h = todo "toName not implemented" h -- TODO -- toName (Exts.UnboxedSingleCon _) = '' -- toName (Exts.ExprHole _) = ''_ instance ToName (Exts.QName l) where -- TODO: why is this commented out? -- toName (Exts.Qual (Exts.Module []) n) = toName n toName (Exts.Qual _ (Exts.ModuleName _ []) n) = toName n toName (Exts.Qual _ (Exts.ModuleName _ m) n) = let m' = show . toName $ m n' = show . toName $ n in toName . concat $ [m',".",n'] toName (Exts.UnQual _ n) = toName n toName (Exts.Special _ s) = toName s #if MIN_VERSION_haskell_src_exts(1,20,1) instance ToName (Exts.MaybePromotedName l) where toName (Exts.PromotedName _ qn) = toName qn toName (Exts.UnpromotedName _ qn) = toName qn #endif instance ToName (Exts.Op l) where toName (Exts.VarOp _ n) = toName n toName (Exts.ConOp _ n) = toName n ----------------------------------------------------------------------------- -- * ToLit HsLiteral instance ToLit (Exts.Literal l) where toLit (Exts.Char _ a _) = TH.CharL a toLit (Exts.String _ a _) = TH.StringL a toLit (Exts.Int _ a _) = TH.IntegerL a toLit (Exts.Frac _ a _) = TH.RationalL a toLit l@Exts.PrimChar{} = noTH "toLit" l toLit (Exts.PrimString _ a _) = TH.StringPrimL (map toWord8 a) where toWord8 = fromIntegral . Char.ord toLit (Exts.PrimInt _ a _) = TH.IntPrimL a toLit (Exts.PrimFloat _ a _) = TH.FloatPrimL a toLit (Exts.PrimDouble _ a _) = TH.DoublePrimL a toLit (Exts.PrimWord _ a _) = TH.WordPrimL a ----------------------------------------------------------------------------- -- * ToPat HsPat instance ToPat (Exts.Pat l) where toPat (Exts.PVar _ n) = TH.VarP (toName n) toPat (Exts.PLit _ (Exts.Signless _) l) = TH.LitP (toLit l) toPat (Exts.PLit _ (Exts.Negative _) l) = TH.LitP $ case toLit l of TH.IntegerL z -> TH.IntegerL (negate z) TH.RationalL q -> TH.RationalL (negate q) TH.IntPrimL z' -> TH.IntPrimL (negate z') TH.FloatPrimL r' -> TH.FloatPrimL (negate r') TH.DoublePrimL r'' -> TH.DoublePrimL (negate r'') _ -> nonsense "toPat" "negating wrong kind of literal" l toPat (Exts.PInfixApp _ p n q) = TH.UInfixP (toPat p) (toName n) (toPat q) toPat (Exts.PApp _ n ps) = TH.ConP (toName n) (fmap toPat ps) toPat (Exts.PTuple _ Exts.Boxed ps) = TH.TupP (fmap toPat ps) toPat (Exts.PTuple _ Exts.Unboxed ps) = TH.UnboxedTupP (fmap toPat ps) toPat (Exts.PList _ ps) = TH.ListP (fmap toPat ps) toPat (Exts.PParen _ p) = TH.ParensP (toPat p) -- TODO: move toFieldPat to top level defn toPat (Exts.PRec _ n pfs) = let toFieldPat (Exts.PFieldPat _ n' p) = (toName n', toPat p) toFieldPat h = todo "toFieldPat" h in TH.RecP (toName n) (fmap toFieldPat pfs) toPat (Exts.PAsPat _ n p) = TH.AsP (toName n) (toPat p) toPat (Exts.PWildCard _) = TH.WildP toPat (Exts.PIrrPat _ p) = TH.TildeP (toPat p) toPat (Exts.PatTypeSig _ p t) = TH.SigP (toPat p) (toType t) toPat (Exts.PViewPat _ e p) = TH.ViewP (toExp e) (toPat p) -- regular pattern toPat p@Exts.PRPat{} = noTH "toPat" p -- XML stuff toPat p@Exts.PXTag{} = noTH "toPat" p toPat p@Exts.PXETag{} = noTH "toPat" p toPat p@Exts.PXPcdata{} = noTH "toPat" p toPat p@Exts.PXPatTag{} = noTH "toPat" p toPat (Exts.PBangPat _ p) = TH.BangP (toPat p) toPat p = todo "toPat" p -- TODO -- (Exts.PNPlusK _ _ _) -- (Exts.PUnboxedSum _ _ _ _) -- (Exts.PXRPats _ _) -- (Exts.PSplice _ _) -- ... ----------------------------------------------------------------------------- -- * ToExp HsExp instance ToExp (Exts.QOp l) where toExp (Exts.QVarOp _ n) = TH.VarE (toName n) toExp (Exts.QConOp _ n) = TH.ConE (toName n) toFieldExp :: Exts.FieldUpdate l -> TH.FieldExp toFieldExp (Exts.FieldUpdate _ n e) = (toName n, toExp e) toFieldExp h = todo "toFieldExp" h instance ToExp (Exts.Exp l) where toExp (Exts.Var _ n) = TH.VarE (toName n) toExp e@Exts.IPVar{} = noTH "toExp" e toExp (Exts.Con _ n) = TH.ConE (toName n) toExp (Exts.Lit _ l) = TH.LitE (toLit l) toExp (Exts.InfixApp _ e o f) = TH.UInfixE (toExp e) (toExp o) (toExp f) #if MIN_VERSION_template_haskell(2,12,0) toExp (Exts.App _ e (Exts.TypeApp _ t)) = TH.AppTypeE (toExp e) (toType t) #else toExp (Exts.App _ _ e@Exts.TypeApp{}) = noTHyet "toExp" "2.12.0" e #endif toExp (Exts.App _ e f) = TH.AppE (toExp e) (toExp f) toExp (Exts.NegApp _ e) = TH.AppE (TH.VarE 'negate) (toExp e) toExp (Exts.Lambda _ ps e) = TH.LamE (fmap toPat ps) (toExp e) toExp (Exts.Let _ bs e) = TH.LetE (toDecs bs) (toExp e) toExp (Exts.If _ a b c) = TH.CondE (toExp a) (toExp b) (toExp c) toExp (Exts.MultiIf _ ifs) = TH.MultiIfE (map toGuard ifs) toExp (Exts.Case _ e alts) = TH.CaseE (toExp e) (map toMatch alts) toExp (Exts.Do _ ss) = TH.DoE (map toStmt ss) toExp e@Exts.MDo{} = noTH "toExp" e toExp (Exts.Tuple _ Exts.Boxed xs) = TH.TupE (fmap toTupEl xs) toExp (Exts.Tuple _ Exts.Unboxed xs) = TH.UnboxedTupE (fmap toTupEl xs) toExp e@Exts.TupleSection{} = noTH "toExp" e toExp (Exts.List _ xs) = TH.ListE (fmap toExp xs) toExp (Exts.Paren _ e) = TH.ParensE (toExp e) toExp (Exts.LeftSection _ e o) = TH.InfixE (Just . toExp $ e) (toExp o) Nothing toExp (Exts.RightSection _ o f) = TH.InfixE Nothing (toExp o) (Just . toExp $ f) toExp (Exts.RecConstr _ n xs) = TH.RecConE (toName n) (fmap toFieldExp xs) toExp (Exts.RecUpdate _ e xs) = TH.RecUpdE (toExp e) (fmap toFieldExp xs) toExp (Exts.EnumFrom _ e) = TH.ArithSeqE $ TH.FromR (toExp e) toExp (Exts.EnumFromTo _ e f) = TH.ArithSeqE $ TH.FromToR (toExp e) (toExp f) toExp (Exts.EnumFromThen _ e f) = TH.ArithSeqE $ TH.FromThenR (toExp e) (toExp f) toExp (Exts.EnumFromThenTo _ e f g) = TH.ArithSeqE $ TH.FromThenToR (toExp e) (toExp f) (toExp g) toExp (Exts.ListComp _ e ss) = TH.CompE $ map convert ss ++ [TH.NoBindS (toExp e)] where convert (Exts.QualStmt _ st) = toStmt st convert s = noTH "toExp ListComp" s toExp (Exts.ExpTypeSig _ e t) = TH.SigE (toExp e) (toType t) toExp e = todo "toExp" e toMatch :: Exts.Alt l -> TH.Match toMatch (Exts.Alt _ p rhs ds) = TH.Match (toPat p) (toBody rhs) (toDecs ds) toBody :: Exts.Rhs l -> TH.Body toBody (Exts.UnGuardedRhs _ e) = TH.NormalB $ toExp e toBody (Exts.GuardedRhss _ rhss) = TH.GuardedB $ map toGuard rhss toGuard :: Exts.GuardedRhs l -> (TH.Guard, TH.Exp) toGuard (Exts.GuardedRhs _ stmts e) = (g, toExp e) where g = case map toStmt stmts of [TH.NoBindS x] -> TH.NormalG x xs -> TH.PatG xs instance ToDecs a => ToDecs (Maybe a) where toDecs Nothing = [] toDecs (Just a) = toDecs a instance ToDecs (Exts.Binds l) where toDecs (Exts.BDecls _ ds) = toDecs ds toDecs a@(Exts.IPBinds {}) = noTH "ToDecs Exts.Binds" a instance ToDecs (Exts.ClassDecl l) where toDecs (Exts.ClsDecl _ d) = toDecs d toDecs x = todo "classDecl" x ----------------------------------------------------------------------------- -- * ToLoc SrcLoc instance ToLoc Exts.SrcLoc.SrcLoc where toLoc (Exts.SrcLoc.SrcLoc fn l c) = TH.Loc fn [] [] (l,c) (-1,-1) ----------------------------------------------------------------------------- -- * ToType HsType instance ToName (Exts.TyVarBind l) where toName (Exts.KindedVar _ n _) = toName n toName (Exts.UnkindedVar _ n) = toName n instance ToName TH.Name where toName = id instance ToName TH.TyVarBndr where toName (TH.PlainTV n) = n toName (TH.KindedTV n _) = n #if !MIN_VERSION_haskell_src_exts(1,21,0) instance ToType (Exts.Kind l) where toType (Exts.KindStar _) = TH.StarT toType (Exts.KindFn _ k1 k2) = toType k1 .->. toType k2 toType (Exts.KindParen _ kp) = toType kp toType (Exts.KindVar _ n) = TH.VarT (toName n) -- TODO LumiGuide: -- toType (Hs.KindVar _ n) -- | isCon (nameBase th_n) = ConT th_n -- | otherwise = VarT th_n -- where -- th_n = toName n -- -- isCon :: String -> Bool -- isCon (c:_) = isUpper c || c == ':' -- isCon _ = nonsense "toType" "empty kind variable name" n toType (Exts.KindApp _ k1 k2) = toType k1 `TH.AppT` toType k2 toType (Exts.KindTuple _ ks) = foldr (\k pt -> pt `TH.AppT` toType k) (TH.TupleT $ length ks) ks toType (Exts.KindList _ k) = TH.ListT `TH.AppT` toType k #endif toKind :: Exts.Kind l -> TH.Kind toKind = toType toTyVar :: Exts.TyVarBind l -> TH.TyVarBndr toTyVar (Exts.KindedVar _ n k) = TH.KindedTV (toName n) (toKind k) toTyVar (Exts.UnkindedVar _ n) = TH.PlainTV (toName n) instance ToType (Exts.Type l) where toType (Exts.TyForall _ tvbM cxt t) = TH.ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t) toType (Exts.TyFun _ a b) = toType a .->. toType b toType (Exts.TyList _ t) = TH.ListT `TH.AppT` toType t toType (Exts.TyTuple _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts) where tuple = case b of Exts.Boxed -> TH.TupleT Exts.Unboxed -> TH.UnboxedTupleT toType (Exts.TyApp _ a b) = TH.AppT (toType a) (toType b) toType (Exts.TyVar _ n) = TH.VarT (toName n) toType (Exts.TyCon _ qn) = TH.ConT (toName qn) toType (Exts.TyParen _ t) = toType t -- XXX: need to wrap the name in parens! #if MIN_VERSION_haskell_src_exts(1,20,0) -- TODO: why does this branch exist? -- Why fail toType if this is a promoted name? toType (Exts.TyInfix _ a (Exts.UnpromotedName _ o) b) = TH.AppT (TH.AppT (TH.ConT (toName o)) (toType a)) (toType b) #else toType (Exts.TyInfix _ a o b) = TH.AppT (TH.AppT (TH.ConT (toName o)) (toType a)) (toType b) #endif toType (Exts.TyKind _ t k) = TH.SigT (toType t) (toKind k) toType (Exts.TyPromoted _ p) = case p of Exts.PromotedInteger _ i _ -> TH.LitT $ TH.NumTyLit i Exts.PromotedString _ _ s -> TH.LitT $ TH.StrTyLit s Exts.PromotedCon _ _q n -> TH.PromotedT $ toName n Exts.PromotedList _ _q ts -> foldr (\t pl -> TH.PromotedConsT `TH.AppT` toType t `TH.AppT` pl) TH.PromotedNilT ts Exts.PromotedTuple _ ts -> foldr (\t pt -> pt `TH.AppT` toType t) (TH.PromotedTupleT $ length ts) ts Exts.PromotedUnit _ -> TH.PromotedT ''() toType (Exts.TyEquals _ t1 t2) = TH.EqualityT `TH.AppT` toType t1 `TH.AppT` toType t2 toType t@Exts.TySplice{} = noTH "toType" t toType t@Exts.TyBang{} = nonsense "toType" "type cannot have strictness annotations in this context" t toType t@Exts.TyWildCard{} = noTH "toType" t toType t = todo "toType" t -- TODO -- toType (Exts.TyUnboxedSum _ _) -- toType (Exts.TyParArray _ _) -- toType (Exts.TyInfix _ _ (Exts.PromotedName _ _) _) toStrictType :: Exts.Type l -> TH.StrictType #if MIN_VERSION_template_haskell(2,11,0) toStrictType (Exts.TyBang _ s u t) = (TH.Bang (toUnpack u) (toStrict s), toType t) where toStrict (Exts.LazyTy _) = TH.SourceLazy toStrict (Exts.BangedTy _) = TH.SourceStrict toStrict (Exts.NoStrictAnnot _) = TH.NoSourceStrictness toUnpack (Exts.Unpack _) = TH.SourceUnpack toUnpack (Exts.NoUnpack _) = TH.SourceNoUnpack toUnpack (Exts.NoUnpackPragma _) = TH.NoSourceUnpackedness toStrictType x = (TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness, toType x) #else -- TODO: what is this comment? Outdated? -- 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 (Exts.TyBang _ b u t) = (toStrict b u, toType t) where toStrict :: Exts.BangType l -> Exts.Unpackedness l -> TH.Strict toStrict (Exts.BangedTy _) _ = TH.IsStrict toStrict _ (Exts.Unpack _) = TH.Unpacked toStrict _ _ = TH.NotStrict toStrictType x = (TH.NotStrict, toType x) #endif (.->.) :: TH.Type -> TH.Type -> TH.Type a .->. b = TH.AppT (TH.AppT TH.ArrowT a) b instance ToPred (Exts.Asst l) where #if MIN_VERSION_haskell_src_exts(1,22,0) toPred (Exts.TypeA _ t) = toType t #else toPred (Exts.ClassA _ n ts) = List.foldl' TH.AppT (TH.ConT (toName n)) (fmap toType ts) toPred (Exts.InfixA _ t1 n t2) = List.foldl' TH.AppT (TH.ConT (toName n)) (fmap toType [t1,t2]) toPred (Exts.EqualP _ t1 t2) = List.foldl' TH.AppT TH.EqualityT (fmap toType [t1,t2]) toPred a@Exts.AppA{} = todo "toPred" a toPred a@Exts.WildCardA{} = todo "toPred" a #endif toPred (Exts.ParenA _ asst) = toPred asst toPred a@Exts.IParam{} = noTH "toPred" a -- Pattern match is redundant. -- TODO: Is there a way to turn off this warn for catch-alls? -- would make the code more future-compat -- toPred p = todo "toPred" p instance ToDerivClauses (Exts.Deriving l) where #if MIN_VERSION_template_haskell(2,12,0) #if MIN_VERSION_haskell_src_exts(1,20,0) toDerivClauses (Exts.Deriving _ strat irules) = [TH.DerivClause (fmap toDerivStrategy strat) (map toType irules)] #else toDerivClauses (Exts.Deriving _ irules) = [TH.DerivClause Nothing (map toType irules)] #endif #elif MIN_VERSION_template_haskell(2,11,0) #if MIN_VERSION_haskell_src_exts(1,20,0) toDerivClauses (Exts.Deriving _ _ irules) = map toType irules #else toDerivClauses (Exts.Deriving _ irules) = map toType irules #endif #else -- template-haskell < 2.11 #if MIN_VERSION_haskell_src_exts(1,20,0) toDerivClauses (Exts.Deriving _ _ irules) = concatMap toNames irules #else toDerivClauses (Exts.Deriving _ irules) = 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 :: (Exts.DerivStrategy l) -> TH.DerivStrategy toDerivStrategy (Exts.DerivStock _) = TH.StockStrategy toDerivStrategy (Exts.DerivAnyclass _) = TH.AnyclassStrategy toDerivStrategy (Exts.DerivNewtype _) = TH.NewtypeStrategy #if MIN_VERSION_haskell_src_exts(1,21,0) #if MIN_VERSION_template_haskell(2,14,0) toDerivStrategy (Exts.DerivVia _ t) = TH.ViaStrategy (toType t) #else toDerivStrategy d@Exts.DerivVia{} = noTHyet "toDerivStrategy" "2.14" d #endif #endif #endif -- TODO LumiGuide -- instance ToCxt (Hs.Deriving l) where -- #if MIN_VERSION_haskell_src_exts(1,20,1) -- toCxt (Hs.Deriving _ _ rule) = toCxt rule -- #else -- toCxt (Hs.Deriving _ rule) = toCxt rule -- #endif -- instance ToCxt [Hs.InstRule l] where -- toCxt = concatMap toCxt -- instance ToCxt a => ToCxt (Maybe a) where -- toCxt Nothing = [] -- toCxt (Just a) = toCxt a foldAppT :: TH.Type -> [TH.Type] -> TH.Type foldAppT t ts = List.foldl' TH.AppT t ts ----------------------------------------------------------------------------- -- * ToStmt HsStmt instance ToStmt (Exts.Stmt l) where toStmt (Exts.Generator _ p e) = TH.BindS (toPat p) (toExp e) toStmt (Exts.Qualifier _ e) = TH.NoBindS (toExp e) toStmt _a@(Exts.LetStmt _ bnds) = TH.LetS (toDecs bnds) toStmt s@Exts.RecStmt{} = noTH "toStmt" s ----------------------------------------------------------------------------- -- * ToDec HsDecl instance ToDec (Exts.Decl l) where toDec (Exts.TypeDecl _ h t) = TH.TySynD (toName h) (toTyVars h) (toType t) toDec a@(Exts.DataDecl _ dOrN cxt h qcds qns) = case dOrN of Exts.DataType _ -> TH.DataD (toCxt cxt) (toName h) (toTyVars h) #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif (fmap qualConDeclToCon qcds) (toDerivClauses qns) Exts.NewType _ -> let qcd = case qcds of [x] -> x _ -> nonsense "toDec" ("newtype with " ++ "wrong number of constructors") a in TH.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@(Exts.TypeSig _ ns t) -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class! = let xs = fmap (flip TH.SigD (toType t) . toName) ns in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!" toDec (Exts.InlineConlikeSig _ act qn) = TH.PragmaD $ TH.InlineP (toName qn) TH.Inline TH.ConLike (transAct act) toDec (Exts.InlineSig _ b act qn) = TH.PragmaD $ TH.InlineP (toName qn) inline TH.FunLike (transAct act) where inline | b = TH.Inline | otherwise = TH.NoInline #if MIN_VERSION_template_haskell(2,11,0) toDec (Exts.TypeFamDecl _ h sig inj) = TH.OpenTypeFamilyD $ TH.TypeFamilyHead (toName h) (toTyVars h) (maybe TH.NoSig TH.KindSig . toMaybeKind $ sig) (fmap toInjectivityAnn inj) toDec (Exts.DataFamDecl _ _ h sig) = TH.DataFamilyD (toName h) (toTyVars h) (toMaybeKind sig) #else toDec (Exts.TypeFamDecl _ h sig inj) = TH.FamilyD TH.TypeFam (toName h) (toTyVars h) (toMaybeKind sig) toDec (Exts.DataFamDecl _ _ h sig) = TH.FamilyD TH.DataFam (toName h) (toTyVars h) (toMaybeKind sig) #endif toDec _a@(Exts.FunBind _ mtchs) = hsMatchesToFunD mtchs toDec (Exts.PatBind _ p rhs bnds) = TH.ValD (toPat p) (hsRhsToBody rhs) (toDecs bnds) toDec i@(Exts.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 (Exts.InstDecl _ Nothing irule ids) = TH.InstanceD Nothing (toCxt irule) (toType irule) (toDecs ids) #else toDec (Exts.InstDecl _ Nothing irule ids) = TH.InstanceD (toCxt irule) (toType irule) (toDecs ids) #endif toDec (Exts.ClassDecl _ cxt h fds decls) = TH.ClassD (toCxt cxt) (toName h) (toTyVars h) (fmap toFunDep fds) (toDecs decls) where toFunDep (Exts.FunDep _ ls rs) = TH.FunDep (fmap toName ls) (fmap toName rs) toDec x = todo "toDec" x instance ToMaybeKind (Exts.ResultSig l) where toMaybeKind (Exts.KindSig _ k) = Just $ toKind k toMaybeKind (Exts.TyVarSig _ _) = Nothing instance ToMaybeKind a => ToMaybeKind (Maybe a) where toMaybeKind Nothing = Nothing toMaybeKind (Just a) = toMaybeKind a #if MIN_VERSION_template_haskell(2,11,0) instance ToInjectivityAnn (Exts.InjectivityInfo l) where toInjectivityAnn (Exts.InjectivityInfo _ n ns) = TH.InjectivityAnn (toName n) (fmap toName ns) #endif transAct :: Maybe (Exts.Activation l) -> TH.Phases transAct Nothing = TH.AllPhases transAct (Just (Exts.ActiveFrom _ n)) = TH.FromPhase n transAct (Just (Exts.ActiveUntil _ n)) = TH.BeforePhase n instance ToName (Exts.DeclHead l) where toName (Exts.DHead _ n) = toName n toName (Exts.DHInfix _ _ n) = toName n toName (Exts.DHParen _ h) = toName h toName (Exts.DHApp _ h _) = toName h instance ToTyVars (Exts.DeclHead l) where toTyVars (Exts.DHead _ _) = [] toTyVars (Exts.DHParen _ h) = toTyVars h toTyVars (Exts.DHInfix _ tvb _) = [toTyVar tvb] toTyVars (Exts.DHApp _ h tvb) = toTyVars h ++ [toTyVar tvb] instance ToNames a => ToNames (Maybe a) where toNames Nothing = [] toNames (Just a) = toNames a instance ToNames (Exts.Deriving l) where #if MIN_VERSION_haskell_src_exts(1,20,0) toNames (Exts.Deriving _ _ irules) = concatMap toNames irules #else toNames (Exts.Deriving _ irules) = concatMap toNames irules #endif instance ToNames (Exts.InstRule l) where toNames (Exts.IParen _ irule) = toNames irule toNames (Exts.IRule _ _mtvbs _mcxt mihd) = toNames mihd instance ToNames (Exts.InstHead l) where toNames (Exts.IHCon _ n) = [toName n] toNames (Exts.IHInfix _ _ n) = [toName n] toNames (Exts.IHParen _ h) = toNames h toNames (Exts.IHApp _ h _) = toNames h instance ToCxt (Exts.InstRule l) where toCxt (Exts.IRule _ _ cxt _) = toCxt cxt toCxt (Exts.IParen _ irule) = toCxt irule instance ToCxt (Exts.Context l) where toCxt x = case x of Exts.CxEmpty _ -> [] Exts.CxSingle _ x' -> [toPred x'] Exts.CxTuple _ xs -> fmap toPred xs instance ToCxt a => ToCxt (Maybe a) where toCxt Nothing = [] toCxt (Just a) = toCxt a instance ToType (Exts.InstRule l) where toType (Exts.IRule _ _ _ h) = toType h toType (Exts.IParen _ irule) = toType irule instance ToType (Exts.InstHead l) where toType (Exts.IHCon _ qn) = toType qn toType (Exts.IHInfix _ typ qn) = TH.AppT (toType typ) (toType qn) toType (Exts.IHParen _ hd) = toType hd toType (Exts.IHApp _ hd typ) = TH.AppT (toType hd) (toType typ) qualConDeclToCon :: Exts.QualConDecl l -> TH.Con qualConDeclToCon (Exts.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl qualConDeclToCon (Exts.QualConDecl _ ns cxt cdecl) = TH.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 (Exts.TyVarBind l) where toTyVars tvb = [toTyVar tvb] instance ToType (Exts.QName l) where toType = TH.ConT . toName conDeclToCon :: Exts.ConDecl l -> TH.Con conDeclToCon (Exts.ConDecl _ n tys) = TH.NormalC (toName n) (map toStrictType tys) conDeclToCon (Exts.RecDecl _ n fieldDecls) = TH.RecC (toName n) (concatMap convField fieldDecls) where convField :: Exts.FieldDecl l -> [TH.VarStrictType] convField (Exts.FieldDecl _ ns t) = let (strict, ty) = toStrictType t in map (\n' -> (toName n', strict, ty)) ns conDeclToCon h = todo "conDeclToCon" h -- TODO -- (Exts.InfixConDecl _ _ _ _) hsMatchesToFunD :: [Exts.Match l] -> TH.Dec hsMatchesToFunD [] = TH.FunD (TH.mkName []) [] -- errorish hsMatchesToFunD xs@(Exts.Match _ n _ _ _ : _) = TH.FunD (toName n) (fmap hsMatchToClause xs) hsMatchesToFunD xs@(Exts.InfixMatch _ _ n _ _ _ : _) = TH.FunD (toName n) (fmap hsMatchToClause xs) hsMatchToClause :: Exts.Match l -> TH.Clause hsMatchToClause (Exts.Match _ _ ps rhs bnds) = TH.Clause (fmap toPat ps) (hsRhsToBody rhs) (toDecs bnds) hsMatchToClause (Exts.InfixMatch _ p _ ps rhs bnds) = TH.Clause (fmap toPat (p:ps)) (hsRhsToBody rhs) (toDecs bnds) hsRhsToBody :: Exts.Rhs l -> TH.Body hsRhsToBody (Exts.UnGuardedRhs _ e) = TH.NormalB (toExp e) hsRhsToBody (Exts.GuardedRhss _ hsgrhs) = let fromGuardedB (TH.GuardedB a) = a fromGuardedB h = todo "fromGuardedB" [h] -- TODO: (NormalB _) in TH.GuardedB . concat . fmap (fromGuardedB . hsGuardedRhsToBody) $ hsgrhs hsGuardedRhsToBody :: Exts.GuardedRhs l -> TH.Body hsGuardedRhsToBody (Exts.GuardedRhs _ [] e) = TH.NormalB (toExp e) hsGuardedRhsToBody (Exts.GuardedRhs _ [s] e) = TH.GuardedB [(hsStmtToGuard s, toExp e)] hsGuardedRhsToBody (Exts.GuardedRhs _ ss e) = let ss' = fmap hsStmtToGuard ss (pgs,ngs) = unzip [(p,n) | (TH.PatG p) <- ss' , n@(TH.NormalG _) <- ss'] e' = toExp e patg = TH.PatG (concat pgs) in TH.GuardedB $ (patg,e') : zip ngs (repeat e') hsStmtToGuard :: Exts.Stmt l -> TH.Guard hsStmtToGuard (Exts.Generator _ p e) = TH.PatG [TH.BindS (toPat p) (toExp e)] hsStmtToGuard (Exts.Qualifier _ e) = TH.NormalG (toExp e) hsStmtToGuard (Exts.LetStmt _ bs) = TH.PatG [TH.LetS (toDecs bs)] hsStmtToGuard h = todo "hsStmtToGuard" h -- TODO -- (Exts.RecStmt _ _) ----------------------------------------------------------------------------- -- * ToDecs InstDecl instance ToDecs (Exts.InstDecl l) where toDecs (Exts.InsDecl _ decl) = toDecs decl toDecs d = todo "toDec" d -- * ToDecs HsDecl HsBinds instance ToDecs (Exts.Decl l) where toDecs _a@(Exts.TypeSig _ ns t) -- TODO: fixforall as before? -- = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns = let xs = fmap (flip TH.SigD (toType t) . toName) ns in xs toDecs (Exts.InfixDecl l assoc Nothing ops) = toDecs (Exts.InfixDecl l assoc (Just 9) ops) toDecs (Exts.InfixDecl _ assoc (Just fixity) ops) = map (\op -> TH.InfixD (TH.Fixity fixity dir) (toName op)) ops where dir = case assoc of Exts.AssocNone _ -> TH.InfixN Exts.AssocLeft _ -> TH.InfixL Exts.AssocRight _ -> TH.InfixR toDecs a = [toDec a] -- TODO: see aboe re: fixforall -- fixForall t@(TH.ForallT _ _ _) = t -- fixForall t = case vs of -- [] -> t -- _ -> TH.ForallT vs [] t -- where vs = collectVars t -- collectVars e = case e of -- VarT n -> [PlainTV n] -- AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2 -- TH.ForallT ns _ t -> collectVars t \\ ns -- _ -> [] instance ToDecs a => ToDecs [a] where toDecs a = concatMap toDecs a ----------------------------------------------------------------------------- haskell-src-meta-0.8.5/src/Language/Haskell/Meta/Utils.hs0000644000000000000000000003042613566633427021311 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} -- TODO {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} -- | This module is a staging ground -- for to-be-organized-and-merged-nicely code. module Language.Haskell.Meta.Utils where import Control.Monad import Data.Generics hiding (Fixity) import Data.List (findIndex) import Language.Haskell.Exts.Pretty (prettyPrint) import Language.Haskell.Meta import Language.Haskell.TH.Lib hiding (cxt) import Language.Haskell.TH.Ppr import Language.Haskell.TH.Syntax import System.IO.Unsafe (unsafePerformIO) import Text.PrettyPrint ----------------------------------------------------------------------------- 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 -- | @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 :: (t1 -> t2 -> a1 -> (a2, t1, t2)) -> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2) 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 unVarT ty = error $ "renameT: unVarT: TODO for" ++ show ty renamePreds = renameThings renamePred renamePred = renameT renameT _ _ t = error $ "renameT: TODO for " ++ show t -- | 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 conTypes c = error $ "conTypes: TODO for " ++ show c -- TODO -- (GadtC _ _ _) -- (RecGadtC _ _ _) 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 conName c = error $ "conName: TODO for" ++ show c -- TODO -- (GadtC _ _ _) -- (RecGadtC _ _ _) 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) = let n = arityT ty in replicateM n (newName "a") >>= \ns -> return (Just (LamE [ConP dConN (fmap VarP ns)] #if MIN_VERSION_template_haskell(2,16,0) (TupE $ fmap (Just . VarE) ns) #else (TupE $ fmap VarE ns) #endif )) #else fromDataConI (DataConI dConN ty _tyConN _fxty) = let n = arityT ty in replicateM n (newName "a") >>= \ns -> return (Just (LamE [ConP dConN (fmap VarP ns)] (TupE $ fmap VarE ns))) #endif 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.5/tests/TestExamples.hs0000644000000000000000000000223113436621420017161 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} import qualified BF import qualified Hs import qualified HsHere import qualified SKI import SKI (SKI ((:$), I, K, S)) -- 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 :: Int) ++"\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|b@(x,_)|] -> [Hs.hs|(b,x)|]) (42 :: Int,88 :: Int) `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.5/examples/BF.hs0000644000000000000000000001462513566633427015536 0ustar0000000000000000-- TODO: knock out these warnings {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module BF ( bf,bf2,bfHelloWorld,eval_,parse, exec, test0 ) where import Language.Haskell.Meta (parsePat) import Language.Haskell.TH.Lib import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import qualified Control.Monad.Fail as Fail import Data.Char import Data.IntMap (IntMap) import qualified Data.IntMap as IM -- TODO: narrow type & move to shared module quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++) -- TODO: narrow type & move to shared module quoteDecNotImplemented :: Fail.MonadFail m => String -> m a quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ ) bf :: QuasiQuoter bf = QuasiQuoter { quoteExp = bfExpQ , quotePat = bfPatQ , quoteType = quoteTypeNotImplemented , quoteDec = quoteDecNotImplemented } bf2 :: QuasiQuoter bf2 = QuasiQuoter { quoteExp = bf2ExpQ , quotePat = bfPatQ , quoteType = quoteTypeNotImplemented , quoteDec = quoteDecNotImplemented } 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)|] #if MIN_VERSION_template_haskell(2,16,0) liftTyped = unsafeTExpCoerce . lift -- TODO: get stylish haskell to be happy w/ the below -- liftTyped Inp = [||Inp||] -- liftTyped Out = [||Out||] -- liftTyped Inc = [||Inc||] -- liftTyped Dec = [||Dec||] -- liftTyped MovL = [||MovL||] -- liftTyped MovR = [||MovR||] -- liftTyped (While xs) = [||While $$(liftTyped xs)||] #endif 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 :: IO [Bf] 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.5/examples/Hs.hs0000644000000000000000000000260313534313562015600 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 import qualified Control.Monad.Fail as Fail -- TODO: narrow type & move to shared module quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++) -- TODO: narrow type & move to shared module quoteDecNotImplemented :: Fail.MonadFail m => String -> m a quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ ) -- | -- > 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 , quoteType = quoteTypeNotImplemented , quoteDec = quoteDecNotImplemented } 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) , quoteType = quoteTypeNotImplemented , quoteDec = quoteDecNotImplemented } haskell-src-meta-0.8.5/examples/HsHere.hs0000644000000000000000000001043313566633427016416 0ustar0000000000000000-- TODO: knock out these warnings {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} module HsHere ( here , lexemeP , nestedP , parensP , bracksP , oparenP , obrackP , cbrackP ) where import qualified Control.Monad.Fail as Fail import Data.Generics (Data) import Data.Typeable (Typeable) import Language.Haskell.Meta (parseExp, parsePat) import Language.Haskell.Meta.Utils (cleanNames) import Language.Haskell.TH.Lib hiding (parensP) import Language.Haskell.TH.Ppr import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Text.ParserCombinators.ReadP -- TODO: narrow type & move to shared module quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++) -- TODO: narrow type & move to shared module quoteDecNotImplemented :: Fail.MonadFail m => String -> m a quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ ) 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 = quoteTypeNotImplemented ,quoteDec = quoteDecNotImplemented ,quoteExp = hereExpQ ,quotePat = herePatQ} instance Lift Here where lift = liftHere #if MIN_VERSION_template_haskell(2,16,0) liftTyped = unsafeTExpCoerce . lift -- TODO: the right way? #endif 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 :: Int -> String -> String -> ReadP Here 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, bracksP :: ReadP a -> ReadP a parensP = between oparenP cparenP bracksP = between oparenP cparenP oparenP, cparenP, obrackP, cbrackP :: ReadP Char oparenP = char '(' cparenP = char ')' obrackP = char '[' cbrackP = char ']' haskell-src-meta-0.8.5/examples/SKI.hs0000644000000000000000000001256713566633427015700 0ustar0000000000000000-- TODO: knock out these warnings {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} module SKI ( SKI(..) , ski , parse , bracksP , obrackP , cbrackP ) where import qualified Control.Monad.Fail as Fail import Data.Generics (Data) import Data.Typeable (Typeable) import Language.Haskell.Meta (parseExp, parsePat) import Language.Haskell.Meta.Utils (cleanNames, ppDoc, unsafeRunQ) import Language.Haskell.TH.Lib hiding (parensP) import Language.Haskell.TH.Ppr import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Text.ParserCombinators.ReadP import Text.PrettyPrint (render) -- TODO: narrow type & move to shared module quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++) -- TODO: narrow type & move to shared module quoteDecNotImplemented :: Fail.MonadFail m => String -> m a quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ ) 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 , quoteType = quoteTypeNotImplemented , quoteDec = quoteDecNotImplemented } instance Lift SKI where lift = liftSKI #if MIN_VERSION_template_haskell(2,16,0) liftTyped = unsafeTExpCoerce . lift -- TODO: the right way? #endif 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.5/tests/Splices.hs0000644000000000000000000000663213557212603016161 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} #if MIN_VERSION_template_haskell(2,12,0) {-# LANGUAGE TypeApplications #-} #endif #if MIN_VERSION_template_haskell(2,14,0) {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE QuantifiedConstraints #-} #endif -- | 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 #if MIN_VERSION_template_haskell(2,14,0) $(either error return $ Meta.parseDecsWithMode (Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.QuantifiedConstraints, Extension.EnableExtension Extension.ExplicitForAll] }) $ unlines ["class (forall a. Eq a => Eq (f a)) => Eq1 f where" ," eq1 :: f Int -> f Int -> Bool" ," eq1 = (==)" ,"" ,"instance Eq1 []"]) #else $(either error return $ Meta.parseDecs $ unlines ["eq1 :: [Int] -> [Int] -> Bool" ,"eq1 = (==)"]) #endif $(either error return $ Meta.parseDecsWithMode (Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.GADTs] }) $ unlines [ -- Not sure why but ghc 7.10 complains that "type var a is not in scope" #if MIN_VERSION_template_haskell(2,11,0) "intConstraint :: (a ~ Int) => a" #else "intConstraint :: Int" #endif ,"intConstraint = 3"]) -- Just to check that it works as intended main :: IO () main = do -9 <- return $(either error return $ Meta.parseExp "-3^2 :: Int") :: IO Int () <- unit [] <- return (nilp []) (1,2) <- return pair (True,1) <- return $ mymethod True 1 "10" <- return tenStr 3 <- return intConstraint True <- return $ eq1 [1] [1] return () haskell-src-meta-0.8.5/tests/Main.hs0000644000000000000000000000341613534313562015441 0ustar0000000000000000{-# LANGUAGE CPP #-} module Main where import qualified Control.Monad.Fail as Fail import qualified Language.Haskell.Exts as Exts import qualified Language.Haskell.Exts.Extension as Extension import qualified Language.Haskell.Exts.Parser as Parser import Language.Haskell.Meta.Parse import qualified Language.Haskell.TH as TH -- import Test.Framework -- import Test.Framework.Providers.HUnit import Test.HUnit (Assertion, (@?=)) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (testCase) type Test = TestTree main :: IO () main = defaultMain (testGroup "unit" 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 :: Fail.MonadFail m => Either String a -> m a liftEither = either fail return haskell-src-meta-0.8.5/LICENSE0000644000000000000000000001744013436621420014062 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.5/Setup.lhs0000644000000000000000000000010113436621420014647 0ustar0000000000000000> import Distribution.Simple > main :: IO () > main = defaultMainhaskell-src-meta-0.8.5/haskell-src-meta.cabal0000644000000000000000000000476213566640413017207 0ustar0000000000000000name: haskell-src-meta version: 0.8.5 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.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1 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.8 && < 5, haskell-src-exts >= 1.18 && < 1.23, pretty >= 1.0 && < 1.2, syb >= 0.1 && < 0.8, template-haskell >= 2.10 && < 2.17, th-orphans >= 0.12 && < 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, base >= 4.5, haskell-src-exts >= 1.17, haskell-src-meta, pretty >= 1.0, template-haskell >= 2.10, tasty, tasty-hunit -- this is needed to access Control.Monad.Fail on GHCs before 8.0 if !impl(ghc >= 8.0) Build-Depends: fail == 4.9.* 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 -- this is needed to access Control.Monad.Fail on GHCs before 8.0 if !impl(ghc >= 8.0) Build-Depends: fail == 4.9.* 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.5/ChangeLog0000644000000000000000000001027713566641160014637 0ustar00000000000000000.8.5: - Compatibility with template-haskell shipped with GHC 8.10 0.8.4: - Bump base and template-haskell library to versions shipped with GHC 7.10 - Compatibility with haskell-src-exts 1.22 0.8.3: - Compatibility with GHC 8.8, by fixing MonadFail issues 0.8.2: - Added ToExp implementation for type application - Added parseDecsWithMode and parseHsDeclsWithMode 0.8.1: - Compatibility with GHC 8.6, haskell-src-exts 1.21 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.5/README.md0000644000000000000000000000173113436621420014330 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.