haskell-src-meta 0.0.3 → 0.0.3.1
raw patch · 11 files changed
+835/−213 lines, 11 filesdep +prettydep ~basedep ~haskell-src-extsdep ~template-haskellsetup-changed
Dependencies added: pretty
Dependency ranges changed: base, haskell-src-exts, template-haskell
Files
- Setup too large to diff
- Setup.lhs +2/−2
- haskell-src-meta.cabal +35/−29
- src/Language/Haskell/Meta.hs +0/−1
- src/Language/Haskell/Meta/Parse.hs +51/−29
- src/Language/Haskell/Meta/QQ/Here.hs +11/−0
- src/Language/Haskell/Meta/QQ/Hs.hs +34/−0
- src/Language/Haskell/Meta/QQ/Vixey.hs +44/−0
- src/Language/Haskell/Meta/Syntax/Translate.hs +156/−151
- src/Language/Haskell/Meta/Utils.hs +501/−0
- src/Language/Haskell/TH/Instances/Lift.hs +1/−1
+ Setup view
file too large to diff
Setup.lhs view
@@ -1,3 +1,3 @@-> import Distribution.Simple -> main :: IO () +> import Distribution.Simple+> main :: IO () > main = defaultMain
haskell-src-meta.cabal view
@@ -1,29 +1,35 @@-name: haskell-src-meta -version: 0.0.3 -cabal-version: >= 1.5 -build-type: Simple -license: BSD3 -license-file: LICENSE -category: Language -author: Matt Morrow -copyright: (c) Matt Morrow -maintainer: Matt Morrow <mjm2002@gmail.com> -stability: experimental -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. - -library - build-tools: - build-Depends: base, containers, haskell-src-exts, - packedstring, template-haskell >= 2.3, syb - extensions: CPP, TemplateHaskell - ghc-options: -O2 -fglasgow-exts - ghc-prof-options: - hs-source-dirs: src - exposed-modules: Language.Haskell.Meta, - Language.Haskell.Meta.Parse, - Language.Haskell.Meta.Syntax, - Language.Haskell.Meta.Syntax.Vars, - Language.Haskell.Meta.Syntax.Translate, - Language.Haskell.TH.Instances.Lift +name: haskell-src-meta+version: 0.0.3.1+cabal-version: >= 1.6+build-type: Simple+license: BSD3+license-file: LICENSE+category: Language+author: Matt Morrow+copyright: (c) Matt Morrow+maintainer: Matt Morrow <mjm2002@gmail.com>+stability: experimental+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.++library+ build-Depends: base == 4.*, containers, haskell-src-exts == 0.4.*,+ packedstring, template-haskell, pretty, syb+ extensions: TemplateHaskell, QuasiQuotes,+ RankNTypes, StandaloneDeriving,+ FlexibleInstances, FlexibleContexts,+ TypeSynonymInstances, PatternGuards+ DeriveDataTypeable+ ghc-options: -O2+ hs-source-dirs: src+ exposed-modules: Language.Haskell.Meta,+ Language.Haskell.Meta.Parse,+ Language.Haskell.Meta.Syntax,+ Language.Haskell.Meta.Syntax.Vars,+ Language.Haskell.Meta.Syntax.Translate,+ Language.Haskell.TH.Instances.Lift,+ Language.Haskell.Meta.Utils,+ Language.Haskell.Meta.QQ.Hs,+ Language.Haskell.Meta.QQ.Here,+ Language.Haskell.Meta.QQ.Vixey
src/Language/Haskell/Meta.hs view
@@ -17,4 +17,3 @@ import Language.Haskell.Meta.Parse import Language.Haskell.Meta.Syntax import Language.Haskell.TH.Instances.Lift-
src/Language/Haskell/Meta/Parse.hs view
@@ -8,18 +8,12 @@ Portability : portable (template-haskell) -} -module Language.Haskell.Meta.Parse (- module Language.Haskell.Meta.Parse- , module Language.Haskell.Exts.Syntax- , module Language.Haskell.Exts.Build- , module Language.Haskell.Exts.Pretty-) where+module Language.Haskell.Meta.Parse where import Language.Haskell.TH.Syntax import Language.Haskell.Meta.Syntax-import Language.Haskell.Exts.Build-import Language.Haskell.Exts.Syntax+import qualified Language.Haskell.Exts.Syntax as Hs import Language.Haskell.Exts.Parser import Language.Haskell.Exts.Pretty @@ -34,6 +28,8 @@ 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 . fmap toDec) . parseHsDecls@@ -43,15 +39,15 @@ -- * haskell-src-exts -parseFile :: FilePath -> IO (ParseResult HsModule)+parseFile :: FilePath -> IO (ParseResult Hs.Module) parseFile fp = readFile fp >>= (return . parseFileContentsWithMode (ParseMode fp)) -parseFileContents :: String -> ParseResult HsModule+parseFileContents :: String -> ParseResult Hs.Module parseFileContents = parseFileContentsWithMode defaultParseMode -parseFileContentsWithMode :: ParseMode -> String -> ParseResult HsModule+parseFileContentsWithMode :: ParseMode -> String -> ParseResult Hs.Module parseFileContentsWithMode p rawStr = parseModuleWithMode p (unlines $ map f $ lines rawStr) where f ('#':_) = "" f x = x@@ -60,69 +56,95 @@ ----------------------------------------------------------------------------- -parseHsModule :: String -> Either String HsModule+parseHsModule :: String -> Either String Hs.Module parseHsModule s = case parseModule s of ParseOk m -> Right m ParseFailed loc e ->- let line = srcLine loc - 1+ let line = Hs.srcLine loc - 1 in Left (unlines [show line,show loc,e]) -parseHsDecls :: String -> Either String [HsDecl]+parseHsDecls :: String -> Either String [Hs.Decl] parseHsDecls s = let s' = unlines [pprHsModule (emptyHsModule "Main"), s] in case parseModule s' of ParseOk m -> Right (moduleDecls m) ParseFailed loc e ->- let line = srcLine loc - 1+ let line = Hs.srcLine loc - 1 in Left (unlines [show line,show loc,e]) -parseHsExp :: String -> Either String HsExp+parseHsType :: String -> Either String Hs.Type+parseHsType s =+ case parseHsDecls ("zomg::\n" ++ (unlines+ . fmap (" "++) . lines $ s ++"\n =()")) of+ Left err -> Left err+ Right xs ->+ case [ t | Hs.PatBind _ _ (Just t) _ _ <- xs] of+ [] -> Left "invalid type"+ (t:_) -> Right t+++parseHsExp :: String -> Either String Hs.Exp parseHsExp s = case parseHsDecls ("main =\n" ++ (unlines . fmap (" "++) . lines $ s)) of Left err -> Left err Right xs ->- case [ e | HsPatBind _ _ (HsUnGuardedRhs e) _ <- xs] of+ case [ e | Hs.PatBind _ _ _ (Hs.UnGuardedRhs e) _ <- xs] of [] -> Left "invalid expression" (e:_) -> Right e -parseHsPat :: String -> Either String HsPat+parseHsPat :: String -> Either String Hs.Pat parseHsPat s = case parseHsDecls ("("++(filter (/='\n') s)++")=()") of Left err -> Left err Right xs ->- case [ p | HsPatBind _ p _ _ <- xs] of+ case [ p | Hs.PatBind _ p _ _ _ <- xs] of [] -> Left "invalid pattern" (p:_) -> Right p -pprHsModule :: HsModule -> String+pprHsModule :: Hs.Module -> String pprHsModule = prettyPrint -moduleDecls :: HsModule -> [HsDecl]-moduleDecls (HsModule _ _ _ _ x) = x+moduleDecls :: Hs.Module -> [Hs.Decl]+moduleDecls (Hs.Module _ _ _ _ _ _ x) = x -mkModule :: String -> Module-mkModule = Module+-- mkModule :: String -> Hs.Module+-- mkModule s = Hs.Module undefined (Hs.ModuleName s) Nothing [] [] -emptySrcLoc :: SrcLoc-emptySrcLoc = (SrcLoc [] 0 0)+emptySrcLoc :: Hs.SrcLoc+emptySrcLoc = (Hs.SrcLoc [] 0 0) -emptyHsModule :: String -> HsModule+emptyHsModule :: String -> Hs.Module emptyHsModule n =- (HsModule+ (Hs.Module emptySrcLoc- (mkModule n)+ (Hs.ModuleName n)+ [] Nothing+ Nothing [] []) +{-+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+-} -----------------------------------------------------------------------------
+ src/Language/Haskell/Meta/QQ/Here.hs view
@@ -0,0 +1,11 @@++-- | Here!++module Language.Haskell.Meta.QQ.Here (here) where++import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lib++here :: QuasiQuoter+here = QuasiQuoter (litE . stringL) (litP . stringL)
+ src/Language/Haskell/Meta/QQ/Hs.hs view
@@ -0,0 +1,34 @@+++-- | Eat your face!++module Language.Haskell.Meta.QQ.Hs (hs, pat) where++import Language.Haskell.Meta+import Language.Haskell.Meta.Utils+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+ (either fail transformE . parseExp)+ (either fail transformP . parsePat)++transformE :: Exp -> ExpQ+transformE = return++transformP :: Pat -> PatQ+transformP = return++pat :: QuasiQuoter+pat = QuasiQuoter+ (quoteExp hs)+ (\s -> case parseExp s of+ Left err -> fail err+ Right e -> either fail return (parsePat . pretty $ e))
+ src/Language/Haskell/Meta/QQ/Vixey.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}++-- | Vixey's idea.++module Language.Haskell.Meta.QQ.Vixey (vix) where++import Data.Generics+ (Data,everywhere,mkT)+import Control.Applicative+import Language.Haskell.Meta+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax++-- ghci> [$i| (,) "foo" "bar" |]+-- [('f','b'),('f','a'),('f','r'),('o','b'),('o','a'),('o','r'),('o','b'),('o','a'),('o','r')]+vix :: QuasiQuoter+vix = QuasiQuoter ((cleanNames <$>) . applicateQ)+ (either fail return . parsePat)++applicateQ :: String -> ExpQ+applicateQ s = case either fail unwindE (parseExp s) of+ x:y:xs -> foldl+ (\e e' -> [|$e <*> $e'|])+ [|$(return x) <$> $(return y)|]+ (fmap return xs)+ _ -> fail "applicateQ fails."++unwindE :: Exp -> [Exp]+unwindE = go []+ where go acc (e `AppE` e') = go (e':acc) e+ go acc e = e:acc++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++
src/Language/Haskell/Meta/Syntax/Translate.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, TypeSynonymInstances #-} {- | Module : Language.Haskell.Meta.Syntax.Translate@@ -17,7 +17,7 @@ import Data.Generics import Data.List (foldl') import Language.Haskell.TH.Syntax-import Language.Haskell.Exts.Syntax+import qualified Language.Haskell.Exts.Syntax as Hs ----------------------------------------------------------------------------- @@ -90,34 +90,35 @@ instance ToName String where toName = mkName -instance ToName HsName where- toName (HsIdent s) = toName s- toName (HsSymbol s) = toName s+instance ToName Hs.Name where+ toName (Hs.Ident s) = toName s+ toName (Hs.Symbol s) = toName s -instance ToName Module where- toName (Module s) = toName s+instance ToName Hs.Module where+ toName (Hs.Module _ (Hs.ModuleName s) _ _ _ _ _) = toName s -instance ToName HsSpecialCon where- toName HsUnitCon = '()- toName HsListCon = '[]- toName HsFunCon = ''(->)- toName (HsTupleCon n)+instance ToName Hs.SpecialCon where+ toName Hs.UnitCon = '()+ toName Hs.ListCon = '[]+ toName Hs.FunCon = ''(->)+ toName (Hs.TupleCon n) | n<2 = '() | otherwise = let x = maybe [] (++".") (nameModule '()) in toName . concat $ x : ["(",replicate (n-1) ',',")"]- toName HsCons = '(:)+ toName Hs.Cons = '(:) -instance ToName HsQName where- toName (Qual (Module []) n) = toName n- toName (Qual m n) =+instance ToName Hs.QName 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 (UnQual n) = toName n- toName (Special s) = toName s+ toName (Hs.UnQual n) = toName n+ toName (Hs.Special s) = toName s @@ -126,16 +127,16 @@ -- * ToLit HsLiteral -instance ToLit HsLiteral where- toLit (HsChar a) = CharL a- toLit (HsString a) = StringL a- toLit (HsInt a) = IntegerL a- toLit (HsFrac a) = RationalL a- toLit (HsCharPrim a) = CharL a -- XXX- toLit (HsStringPrim a) = StringL a -- XXX- toLit (HsIntPrim a) = IntPrimL a- toLit (HsFloatPrim a) = FloatPrimL a- toLit (HsDoublePrim a) = DoublePrimL a+instance ToLit Hs.Literal where+ toLit (Hs.Char a) = CharL a+ toLit (Hs.String a) = StringL a+ toLit (Hs.Int a) = IntegerL a+ toLit (Hs.Frac a) = RationalL a+ toLit (Hs.PrimChar a) = CharL a -- XXX+ toLit (Hs.PrimString a) = StringL a -- XXX+ toLit (Hs.PrimInt a) = IntPrimL a+ toLit (Hs.PrimFloat a) = FloatPrimL a+ toLit (Hs.PrimDouble a) = DoublePrimL a -----------------------------------------------------------------------------@@ -143,47 +144,47 @@ -- * ToPat HsPat -instance ToPat HsPat where- toPat (HsPVar n)+instance ToPat Hs.Pat where+ toPat (Hs.PVar n) = VarP (toName n)- toPat (HsPLit l)+ toPat (Hs.PLit l) = LitP (toLit l) {- ghci> parseHsPat "-2" Right (HsPParen (HsPNeg (HsPLit (HsInt 2)))) -}- toPat (HsPNeg p) = error "toPat: HsPNeg not supported"- toPat (HsPInfixApp p n q)= InfixP (toPat p) (toName n) (toPat q)- toPat (HsPApp n ps) = ConP (toName n) (fmap toPat ps)- toPat (HsPTuple ps) = TupP (fmap toPat ps)- toPat (HsPList ps) = ListP (fmap toPat ps)- toPat (HsPParen p) = toPat p- toPat (HsPRec n pfs) = let toFieldPat (HsPFieldPat n p) = (toName n, toPat p)+ toPat (Hs.PNeg p) = error "toPat: HsPNeg not supported"+ toPat (Hs.PInfixApp p n q)= InfixP (toPat p) (toName n) (toPat q)+ toPat (Hs.PApp n ps) = ConP (toName n) (fmap toPat ps)+ toPat (Hs.PTuple ps) = TupP (fmap toPat ps)+ toPat (Hs.PList ps) = ListP (fmap toPat ps)+ toPat (Hs.PParen p) = toPat p+ toPat (Hs.PRec n pfs) = let toFieldPat (Hs.PFieldPat n p) = (toName n, toPat p) in RecP (toName n) (fmap toFieldPat pfs)- toPat (HsPAsPat n p) = AsP (toName n) (toPat p)- toPat (HsPWildCard) = WildP- toPat (HsPIrrPat p) = TildeP (toPat p)- toPat (HsPatTypeSig _ p t) = SigP (toPat p) (toType t)- toPat (HsPRPat rps) = error "toPat: HsRPat not supported"- toPat (HsPXTag _ _ _ pM p) = error "toPat: HsPXTag not supported"- toPat (HsPXETag _ _ _ pM) = error "toPat: HsPXETag not supported"- toPat (HsPXPcdata _) = error "toPat: HsPXPcdata not supported"- toPat (HsPXPatTag p) = error "toPat: HsPXPatTag not supported"+ toPat (Hs.PAsPat n p) = AsP (toName n) (toPat p)+ toPat (Hs.PWildCard) = WildP+ toPat (Hs.PIrrPat p) = TildeP (toPat p)+ toPat (Hs.PatTypeSig _ p t) = SigP (toPat p) (toType t)+ toPat (Hs.PRPat rps) = error "toPat: HsRPat not supported"+ toPat (Hs.PXTag _ _ _ pM p) = error "toPat: HsPXTag not supported"+ toPat (Hs.PXETag _ _ _ pM) = error "toPat: HsPXETag not supported"+ toPat (Hs.PXPcdata _) = error "toPat: HsPXPcdata not supported"+ toPat (Hs.PXPatTag p) = error "toPat: HsPXPatTag not supported" ----------------------------------------------------------------------------- -- * ToExp HsExp -instance ToExp HsQOp where- toExp (HsQVarOp n) = VarE (toName n)- toExp (HsQConOp n) = ConE (toName n)+instance ToExp Hs.QOp where+ toExp (Hs.QVarOp n) = VarE (toName n)+ toExp (Hs.QConOp n) = ConE (toName n) -toFieldExp :: HsFieldUpdate -> FieldExp-toFieldExp (HsFieldUpdate n e) = (toName n, toExp e)+toFieldExp :: Hs.FieldUpdate -> FieldExp+toFieldExp (Hs.FieldUpdate n e) = (toName n, toExp e) -instance ToExp HsExp where+instance ToExp Hs.Exp where {- data HsExp = HsVar HsQName@@ -198,35 +199,35 @@ -- use mfix somehow | HsMDo [HsStmt] -}- toExp (HsVar n) = VarE (toName n)- toExp (HsCon n) = ConE (toName n)- toExp (HsLit l) = LitE (toLit l)- toExp (HsInfixApp e o f) = InfixE (Just . toExp $ e) (toExp o) (Just . toExp $ f)- toExp (HsLeftSection e o) = InfixE (Just . toExp $ e) (toExp o) Nothing- toExp (HsRightSection o f) = InfixE Nothing (toExp o) (Just . toExp $ f)- toExp (HsApp e f) = AppE (toExp e) (toExp f)- toExp (HsNegApp e) = AppE (VarE 'negate) (toExp e)- toExp (HsLambda _ ps e) = LamE (fmap toPat ps) (toExp e)- toExp (HsLet bs e) = LetE (hsBindsToDecs bs) (toExp e)+ toExp (Hs.Var n) = VarE (toName n)+ toExp (Hs.Con n) = ConE (toName n)+ toExp (Hs.Lit l) = LitE (toLit l)+ toExp (Hs.InfixApp e o f) = InfixE (Just . toExp $ e) (toExp o) (Just . toExp $ f)+ toExp (Hs.LeftSection e o) = InfixE (Just . toExp $ e) (toExp o) Nothing+ toExp (Hs.RightSection o f) = InfixE Nothing (toExp o) (Just . toExp $ f)+ toExp (Hs.App e f) = AppE (toExp e) (toExp f)+ toExp (Hs.NegApp e) = AppE (VarE 'negate) (toExp e)+ toExp (Hs.Lambda _ ps e) = LamE (fmap toPat ps) (toExp e)+ toExp (Hs.Let bs e) = LetE (hsBindsToDecs bs) (toExp e) -- toExp (HsWith e bs- toExp (HsIf a b c) = CondE (toExp a) (toExp b) (toExp c)+ toExp (Hs.If a b c) = CondE (toExp a) (toExp b) (toExp c) -- toExp (HsCase e xs) -- toExp (HsDo ss) -- toExp (HsMDo ss)- toExp (HsTuple xs) = TupE (fmap toExp xs)- toExp (HsList xs) = ListE (fmap toExp xs)- toExp (HsParen e) = toExp e- toExp (HsRecConstr n xs) = RecConE (toName n) (fmap toFieldExp xs)- toExp (HsRecUpdate e xs) = RecUpdE (toExp e) (fmap toFieldExp xs)- toExp (HsEnumFrom e) = ArithSeqE $ FromR (toExp e)- toExp (HsEnumFromTo e f) = ArithSeqE $ FromToR (toExp e) (toExp f)- toExp (HsEnumFromThen e f) = ArithSeqE $ FromThenR (toExp e) (toExp f)- toExp (HsEnumFromThenTo e f g) = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g)- toExp (HsExpTypeSig _ e t) = SigE (toExp e) (toType t)+ toExp (Hs.Tuple xs) = TupE (fmap toExp xs)+ toExp (Hs.List xs) = ListE (fmap toExp xs)+ toExp (Hs.Paren e) = toExp e+ toExp (Hs.RecConstr n xs) = RecConE (toName n) (fmap toFieldExp xs)+ toExp (Hs.RecUpdate e xs) = RecUpdE (toExp e) (fmap toFieldExp xs)+ toExp (Hs.EnumFrom e) = ArithSeqE $ FromR (toExp e)+ toExp (Hs.EnumFromTo e f) = ArithSeqE $ FromToR (toExp e) (toExp f)+ toExp (Hs.EnumFromThen e f) = ArithSeqE $ FromThenR (toExp e) (toExp f)+ toExp (Hs.EnumFromThenTo e f g) = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g)+ toExp (Hs.ExpTypeSig _ e t) = SigE (toExp e) (toType t) -- HsListComp HsExp [HsStmt] -- toExp (HsListComp e ss) = CompE -- NEED: a way to go e -> Stmt- toExp a@(HsListComp e ss) = error $ errorMsg "toExp" a+ toExp a@(Hs.ListComp e ss) = error $ errorMsg "toExp" a {- HsVarQuote HsQName | HsTypQuote HsQName | HsBracketExp HsBracket@@ -237,13 +238,13 @@ | HsTypeBracket HsType | HsDeclBracket [HsDecl] data HsSplice = HsIdSplice String | HsParenSplice HsExp -}- toExp (HsSpliceExp spl) = toExp spl+ toExp (Hs.SpliceExp spl) = toExp spl toExp e = error $ errorMsg "toExp" e -instance ToExp HsSplice where- toExp (HsIdSplice s) = VarE (toName s)- toExp (HsParenSplice e) = toExp e+instance ToExp Hs.Splice where+ toExp (Hs.IdSplice s) = VarE (toName s)+ toExp (Hs.ParenSplice e) = toExp e -----------------------------------------------------------------------------@@ -280,17 +281,17 @@ -- * ToLoc SrcLoc -instance ToLoc SrcLoc where- toLoc (SrcLoc fn l c) =+instance ToLoc Hs.SrcLoc where+ toLoc (Hs.SrcLoc fn l c) = Loc fn [] [] (l,c) (-1,-1) ----------------------------------------------------------------------------- -- * ToType HsType -instance ToName HsTyVarBind where- toName (HsKindedVar n _) = toName n- toName (HsUnkindedVar n) = toName n+instance ToName Hs.TyVarBind where+ toName (Hs.KindedVar n _) = toName n+ toName (Hs.UnkindedVar n) = toName n {- | TH does't handle@@ -299,18 +300,18 @@ * infix type constructors * kind signatures -}-instance ToType HsType where- toType (HsTyForall tvbM cxt t) = ForallT (maybe [] (fmap toName) tvbM) (fmap toType cxt) (toType t)- toType (HsTyFun a b) = toType a .->. toType b- toType (HsTyTuple _ ts) = foldAppT (TupleT . length $ ts) (fmap toType ts)- toType (HsTyApp a b) = AppT (toType a) (toType b)- toType (HsTyVar n) = VarT (toName n)- toType (HsTyCon qn) = ConT (toName qn)- toType a@(HsTyPred _) = error $ errorMsg "toType" a+instance ToType Hs.Type where+ toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toName) tvbM) (fmap toType cxt) (toType t)+ toType (Hs.TyFun a b) = toType a .->. toType b+ toType (Hs.TyTuple _ ts) = foldAppT (TupleT . length $ ts) (fmap toType ts)+ toType (Hs.TyApp a b) = AppT (toType a) (toType b)+ toType (Hs.TyVar n) = VarT (toName n)+ toType (Hs.TyCon qn) = ConT (toName qn)+ toType a@(Hs.TyPred _) = error $ errorMsg "toType" a -- XXX: need to wrap the name in parens!- toType (HsTyInfix a qn b) = foldAppT (ConT . toName $ qn) (fmap toType [a,b])- toType (HsTyKind t _) = toType t+ toType (Hs.TyInfix a qn b) = foldAppT (ConT . toName $ qn) (fmap toType [a,b])+ toType (Hs.TyKind t _) = toType t (.->.) :: Type -> Type -> Type a .->. b = AppT (AppT ArrowT a) b@@ -320,10 +321,10 @@ * implicit params * equality constraints -}-instance ToType HsAsst where- toType (HsClassA n ts) = foldAppT (ConT . toName $ n) (fmap toType ts)- toType a@(HsIParam _ _) = error $ errorMsg "toType" a- toType a@(HsEqualP _ _) = error $ errorMsg "toType" a+instance ToType Hs.Asst where+ toType (Hs.ClassA n ts) = foldAppT (ConT . toName $ n) (fmap toType ts)+ toType a@(Hs.IParam _ _) = error $ errorMsg "toType" a+ toType a@(Hs.EqualP _ _) = error $ errorMsg "toType" a foldAppT :: Type -> [Type] -> Type foldAppT t ts = foldl' AppT t ts@@ -332,10 +333,10 @@ -- * ToStmt HsStmt -instance ToStmt HsStmt where- toStmt (HsGenerator _ p e) = BindS (toPat p) (toExp e)- toStmt (HsQualifier e) = NoBindS (toExp e)- toStmt a@(HsLetStmt bnds) = LetS (hsBindsToDecs bnds)+instance ToStmt Hs.Stmt where+ toStmt (Hs.Generator _ p e) = BindS (toPat p) (toExp e)+ toStmt (Hs.Qualifier e) = NoBindS (toExp e)+ toStmt a@(Hs.LetStmt bnds) = LetS (hsBindsToDecs bnds) -----------------------------------------------------------------------------@@ -343,15 +344,15 @@ -- * ToDec HsDecl -- data HsBinds = HsBDecls [HsDecl] | HsIPBinds [HsIPBind]-hsBindsToDecs :: HsBinds -> [Dec]-hsBindsToDecs (HsBDecls ds) = fmap toDec ds-hsBindsToDecs a@(HsIPBinds ipbs) = error $ errorMsg "hsBindsToDecs" a+hsBindsToDecs :: Hs.Binds -> [Dec]+hsBindsToDecs (Hs.BDecls ds) = fmap toDec ds+hsBindsToDecs a@(Hs.IPBinds ipbs) = error $ errorMsg "hsBindsToDecs" a -- data HsIPBind = HsIPBind SrcLoc HsIPName HsExp -hsBangTypeToStrictType :: HsBangType -> (Strict, Type)-hsBangTypeToStrictType (HsBangedTy t) = (IsStrict, toType t)-hsBangTypeToStrictType (HsUnBangedTy t) = (NotStrict, toType t)+hsBangTypeToStrictType :: Hs.BangType -> (Strict, Type)+hsBangTypeToStrictType (Hs.BangedTy t) = (IsStrict, toType t)+hsBangTypeToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t) {-@@ -368,9 +369,9 @@ HsRecDecl n assocs -> -} -instance ToDec HsDecl where- toDec (HsTypeDecl _ n ns t) = TySynD (toName n) (fmap toName ns) (toType t)- toDec a@(HsDataDecl _ dOrN cxt n ns qcds qns) = error $ errorMsg "toDec" a+instance ToDec Hs.Decl where+ toDec (Hs.TypeDecl _ n ns t) = TySynD (toName n) (fmap toName ns) (toType t)+ toDec a@(Hs.DataDecl _ dOrN cxt n ns qcds qns) = error $ errorMsg "toDec" a {- data HsQualConDecl = HsQualConDecl SrcLoc @@ -385,45 +386,49 @@ (fmap toName ns) NewType -> -}- toDec a@(HsGDataDecl _ dOrN cxt n ns kM gadtDecs) = error $ errorMsg "toDec" a- toDec a@(HsTypeFamDecl _ n ns kM) = error $ errorMsg "toDec" a- toDec a@(HsDataFamDecl _ cxt n ns kM) = error $ errorMsg "toDec" a- toDec a@(HsTypeInsDecl _ ta tb) = error $ errorMsg "toDec" a- toDec a@(HsDataInsDecl _ dOrN t qcds qns) = error $ errorMsg "toDec" a- toDec a@(HsGDataInsDecl _ dOrN t kM gadtDecs) = error $ errorMsg "toDec" a+ toDec a@(Hs.GDataDecl _ dOrN cxt n ns kM gadtDecs _) = error $ errorMsg "toDec" a+ toDec a@(Hs.TypeFamDecl _ n ns kM) = error $ errorMsg "toDec" a+ toDec a@(Hs.DataFamDecl _ cxt n ns kM) = error $ errorMsg "toDec" a+ toDec a@(Hs.TypeInsDecl _ ta tb) = error $ errorMsg "toDec" a+ toDec a@(Hs.DataInsDecl _ dOrN t qcds qns) = error $ errorMsg "toDec" a+ toDec a@(Hs.GDataInsDecl _ dOrN t kM gadtDecs _) = error $ errorMsg "toDec" a -- data HsOp = HsVarOp HsName | HsConOp HsName- toDec a@(HsInfixDecl _ asst i ops) = error $ errorMsg "toDec" a- toDec a@(HsClassDecl _ cxt n ns funDeps cDecs) = error $ errorMsg "toDec" a- toDec a@(HsInstDecl _ cxt qn ts instDecs) = error $ errorMsg "toDec" a- toDec a@(HsDerivDecl _ cxt qn ts) = error $ errorMsg "toDec" a - toDec a@(HsDefaultDecl _ ts) = error $ errorMsg "toDec" a- toDec a@(HsSpliceDecl _ s) = error $ errorMsg "toDec" a- toDec a@(HsTypeSig _ ns t) = error $ errorMsg "toDec" a+ toDec a@(Hs.InfixDecl _ asst i ops) = error $ errorMsg "toDec" a+ toDec a@(Hs.ClassDecl _ cxt n ns funDeps cDecs) = error $ errorMsg "toDec" a+ toDec a@(Hs.InstDecl _ cxt qn ts instDecs) = error $ errorMsg "toDec" a+ toDec a@(Hs.DerivDecl _ cxt qn ts) = error $ errorMsg "toDec" a + toDec a@(Hs.DefaultDecl _ ts) = error $ errorMsg "toDec" a+ toDec a@(Hs.SpliceDecl _ s) = error $ errorMsg "toDec" a+ toDec a@(Hs.TypeSig _ ns t) = error $ errorMsg "toDec" a {- data HsDecl = ... | HsFunBind [HsMatch] | ... data HsMatch = HsMatch SrcLoc HsName [HsPat] HsRhs HsBinds data Dec = FunD Name [Clause] | ... data Clause = Clause [Pat] Body [Dec] -}- toDec a@(HsFunBind mtchs) = hsMatchesToFunD mtchs+ toDec a@(Hs.FunBind mtchs) = hsMatchesToFunD mtchs {- ghci> parseExp "let x = 2 in x" LetE [ValD (VarP x) (NormalB (LitE (IntegerL 2))) []] (VarE x) ghci> unQ[| let x = 2 in x |] LetE [ValD (VarP x_0) (NormalB (LitE (IntegerL 2))) []] (VarE x_0) -}- toDec (HsPatBind _ p rhs bnds) = ValD (toPat p) (hsRhsToBody rhs) (hsBindsToDecs bnds)- toDec a@(HsForImp _ cconv safe str n t) = error $ errorMsg "toDec" a- toDec a@(HsForExp _ cconv str n t) = error $ errorMsg "toDec" a+ toDec (Hs.PatBind _ p tM rhs bnds) = ValD ((maybe id+ (flip SigP . toType)+ tM) (toPat p))+ (hsRhsToBody rhs)+ (hsBindsToDecs bnds)+ toDec a@(Hs.ForImp _ cconv safe str n t) = error $ errorMsg "toDec" a+ toDec a@(Hs.ForExp _ cconv str n t) = error $ errorMsg "toDec" a -hsMatchesToFunD :: [HsMatch] -> Dec+hsMatchesToFunD :: [Hs.Match] -> Dec hsMatchesToFunD [] = FunD (mkName []) [] -- errorish-hsMatchesToFunD xs@(HsMatch _ n _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs)+hsMatchesToFunD xs@(Hs.Match _ n _ _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs) -hsMatchToClause :: HsMatch -> Clause-hsMatchToClause (HsMatch _ _ ps rhs bnds) = Clause- (fmap toPat ps)- (hsRhsToBody rhs)- (hsBindsToDecs bnds)+hsMatchToClause :: Hs.Match -> Clause+hsMatchToClause (Hs.Match _ _ ps _ rhs bnds) = Clause+ (fmap toPat ps)+ (hsRhsToBody rhs)+ (hsBindsToDecs bnds) @@ -431,32 +436,32 @@ -- data HsGuardedRhs = HsGuardedRhs SrcLoc [HsStmt] HsExp -- data Body = GuardedB [(Guard, Exp)] | NormalB Exp -- data Guard = NormalG Exp | PatG [Stmt]-hsRhsToBody :: HsRhs -> Body-hsRhsToBody (HsUnGuardedRhs e) = NormalB (toExp e)-hsRhsToBody (HsGuardedRhss hsgrhs) = let fromGuardedB (GuardedB a) = a+hsRhsToBody :: Hs.Rhs -> Body+hsRhsToBody (Hs.UnGuardedRhs e) = NormalB (toExp e)+hsRhsToBody (Hs.GuardedRhss hsgrhs) = let fromGuardedB (GuardedB a) = a in GuardedB . concat . fmap (fromGuardedB . hsGuardedRhsToBody) $ hsgrhs -hsGuardedRhsToBody :: HsGuardedRhs -> Body-hsGuardedRhsToBody (HsGuardedRhs _ [] e) = NormalB (toExp e)-hsGuardedRhsToBody (HsGuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)]-hsGuardedRhsToBody (HsGuardedRhs _ 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)+hsGuardedRhsToBody :: Hs.GuardedRhs -> Body+hsGuardedRhsToBody (Hs.GuardedRhs _ [] e) = NormalB (toExp e)+hsGuardedRhsToBody (Hs.GuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)]+hsGuardedRhsToBody (Hs.GuardedRhs _ ss e) = let ss' = fmap hsStmtToGuard ss+ (pgs,ngs) = unzip [(p,n)+ | (PatG p) <- ss'+ , n@(NormalG _) <- ss']+ e' = toExp e+ patg = PatG (concat pgs) in GuardedB $ (patg,e') : zip ngs (repeat e') -hsStmtToGuard :: HsStmt -> Guard-hsStmtToGuard (HsGenerator _ p e) = PatG [BindS (toPat p) (toExp e)]-hsStmtToGuard (HsQualifier e) = NormalG (toExp e)-hsStmtToGuard a@(HsLetStmt _) = error $ errorMsg "hsStmtToGuardExp" a+hsStmtToGuard :: Hs.Stmt -> Guard+hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)]+hsStmtToGuard (Hs.Qualifier e) = NormalG (toExp e)+hsStmtToGuard a@(Hs.LetStmt _) = error $ errorMsg "hsStmtToGuardExp" a -----------------------------------------------------------------------------
+ src/Language/Haskell/Meta/Utils.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE TemplateHaskell, RankNTypes, StandaloneDeriving,+ 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.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 . unQ+instance Show (Q [Dec]) where show = unlines . fmap (show . cleanNames) . unQ+instance Show DecQ where show = show . cleanNames . unQ+instance Show TypeQ where show = show . cleanNames . unQ+instance Show (Q String) where show = unQ+instance Show (Q Doc) where show = show . unQ++deriving instance Typeable1 Q+deriving instance Typeable QuasiQuoter+++-- | @unQ = unsafePerformIO . runQ@+unQ :: Q a -> a+unQ = 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` "><.\\/!@#$%^&*-+?:|")+++-----------------------------------------------------------------------------+++(|$|) :: 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++++myNames :: [Name]+myNames = let xs = fmap (:[]) ['a'..'z']+ ys = iterate (join (zipWith (++))) xs+ in fmap mkName (concat ys)+++renameTs env new acc [] = (reverse acc, env, new)+renameTs env new acc (t:ts) =+ let (t',env',new') = renameT env new t+ in renameTs env' new' (t':acc) ts++renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name,Name)], [Name])+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 ((mkName . nameBase) 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 unVarT (VarT n) = n+ (ns',env2,new2) = renameTs env new [] (fmap VarT ns)+ ns'' = fmap unVarT ns'+ (cxt',env3,new3) = renameTs env2 new2 [] cxt+ (t',env4,new4) = renameT env3 new3 t+ in (ForallT ns'' cxt' t', env4, new4)++++applyT :: Type -> Type -> Type+applyT (ForallT [] _ t) t' = t `AppT` t'+applyT (ForallT (n:ns) cxt t) t' = ForallT ns cxt (substT [(n,t')] ns t)+applyT t t' = t `AppT` t'++++substT :: [(Name, Type)] -> [Name] -> Type -> Type+substT env bnd (ForallT ns _ t) = substT env (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++++++-- | Stolen from Igloo's th-lift.+deriveLift :: Name -> Q Dec+deriveLift n+ = do i <- reify n+ case i of+ TyConI (DataD _ _ vs cons _) ->+ let ctxt = cxt [conT ''Lift `appT` varT v | v <- vs]+ typ = foldl appT (conT n) $ map varT vs+ fun = funD 'lift (map doCons cons)+ in instanceD ctxt (conT ''Lift `appT` typ) [fun]+ _ -> error (modName ++ ".deriveLift: unhandled: " ++ pprint i)+ where modName :: String+ modName = "Language.Haskell.TH.Utils"+ doCons :: Con -> Q Clause+ doCons (NormalC c sts) = do+ let ns = zipWith (\_ i -> "x" ++ show i) sts [0..]+ con = [| conE c |]+ args = [ [| lift $(varE (mkName n)) |] | n <- ns ]+ e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args+ clause [conP c (map (varP . mkName) ns)] (normalB e) []+ doCons c = error (modName ++ ".doCons: Unhandled constructor: " ++ pprint c)++++-- | Produces pretty code suitable+-- for human consumption.+deriveLiftPretty :: Name -> Q String+deriveLiftPretty n = do+ decs <- deriveLift n+ case (parseHsDecls . pprint . cleanNames) decs of+ Left e -> fail ("deriveLiftPretty: error while prettifying code: "++e)+ Right hsdecs -> return (unlines . fmap prettyPrint $ hsdecs)+++++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]+decCons (DataD _ _ _ cons _) = cons+decCons (NewtypeD _ _ _ con _) = [con]+decCons _ = []+++decTyVars :: Dec -> [Name]+decTyVars (DataD _ _ ns _ _) = ns+decTyVars (NewtypeD _ _ ns _ _) = ns+decTyVars (TySynD _ ns _) = ns+decTyVars (ClassD _ _ ns _ _) = ns+decTyVars _ = []+++decName :: Dec -> Maybe Name+decName (FunD n _) = Just n+decName (DataD _ n _ _ _) = Just n+decName (NewtypeD _ n _ _ _) = Just n+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]+dataDCons (DataD _ _ _ cons _) = cons+dataDCons _ = []++fromDataConI :: Info -> Q (Maybe Exp)+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)))+fromDataConI _ = return Nothing++fromTyConI :: Info -> Maybe Dec+fromTyConI (TyConI dec) = Just dec+fromTyConI _ = Nothing+++-----------------------------------------------------------------------------++-- | 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) | n == ''(,) = TupleT 2+ go (ConT n) | n == ''(,,) = TupleT 3+ go (ConT n) | n == ''(,,,) = TupleT 4+ go (ConT n) | n == ''(,,,,) = TupleT 5+ go (ConT n) | n == ''(,,,,,) = TupleT 6+ go (ConT n) | n == ''(,,,,,,) = TupleT 7+ go (ConT n) | n == ''(,,,,,,,) = TupleT 8+ go (ConT n) | n == ''(,,,,,,,,) = TupleT 9+ go (ConT n) | n == ''(,,,,,,,,,) = TupleT 10+ go (ConT n) | n == ''(,,,,,,,,,,) = TupleT 11+ go (ConT n) | n == ''(,,,,,,,,,,,) = TupleT 12+ go (ConT n) | n == ''(,,,,,,,,,,,,) = TupleT 13+ go (ConT n) | n == ''(,,,,,,,,,,,,,) = TupleT 14+ go (ConT n) | n == ''(,,,,,,,,,,,,,,) = TupleT 15+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,) = TupleT 16+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,) = TupleT 17+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,) = TupleT 18+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,) = TupleT 19+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,) = TupleT 20+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,) = TupleT 21+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,) = TupleT 22+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,) = TupleT 23+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 24+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 25+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 26+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 27+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 28+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 29+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 30+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 31+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 32+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 33+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 34+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 35+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 36+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 37+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 38+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 39+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 40+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 41+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 42+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 43+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 44+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 45+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 46+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 47+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 48+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 49+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 50+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 51+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 52+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 53+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 54+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 55+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 56+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 57+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 58+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 59+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 60+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 61+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 62+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 63+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 64+ go t = t++++-----------------------------------------------------------------------------+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Language/Haskell/TH/Instances/Lift.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, CPP #-}+{-# LANGUAGE TemplateHaskell, CPP, MagicHash, TypeSynonymInstances #-} {- | Module : Language.Haskell.TH.Instances.Lift