LambdaPrettyQuote 0.0.0.1 → 0.0.0.2
raw patch · 3 files changed
+102/−51 lines, 3 filesdep +sybdep +th-instancesdep +uniplatedep ~lambda-ast
Dependencies added: syb, th-instances, uniplate
Dependency ranges changed: lambda-ast
Files
- LambdaPrettyQuote.cabal +12/−6
- src/Language/Lambda/Parser.hs +37/−27
- src/Language/Lambda/Quote.hs +53/−18
LambdaPrettyQuote.cabal view
@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.0.0.1+Version: 0.0.0.2 -- A short (one-line) description of the package. Synopsis: Parser, pretty printer, quasiquoter, and Arbitrary helpers for the untyped lambda calculus.@@ -15,7 +15,8 @@ homepage: http://github.com/jfischoff/LambdaPrettyQuote -- A longer description of the package.--- Description: +Description: + CHANGES -- 0.0.0.2 added \"anti\" expressions for the quasiquoter to capture variables from the environment. Also added a pattern quasiquoter. -- The license under which the package is released. License: BSD3@@ -55,12 +56,14 @@ test-framework-quickcheck2 >= 0.2.10, test-framework-hunit >= 0.2.7, test-framework >= 0.4.1.1,- lambda-ast,+ lambda-ast >= 0.0.4, HUnit >= 1.2.4.2, DebugTraceHelpers >= 0.12, template-haskell >= 2.6.0.0, transformers >= 0.2.2.0,- parsec >= 3.1.2+ parsec >= 3.1.2,+ uniplate >= 1.6.5,+ syb >= 0.3.5 ghc-options: -Wall Test-Suite tests@@ -72,10 +75,13 @@ test-framework-quickcheck2 >= 0.2.10, test-framework-hunit >= 0.2.7, test-framework >= 0.4.1.1,- lambda-ast,+ lambda-ast >= 0.0.4, HUnit >= 1.2.4.2, DebugTraceHelpers >= 0.12, template-haskell >= 2.6.0.0, transformers >= 0.2.2.0,- parsec >= 3.1.2 + parsec >= 3.1.2, + uniplate >= 1.6.5,+ th-instances >= 0.1.0.2,+ syb >= 0.3.5
src/Language/Lambda/Parser.hs view
@@ -1,22 +1,23 @@-{-# LANGUAGE FlexibleContexts #-}-{-- | Parser for the lambda AST built of parsec. No Support for AntiExpr yet. Probably not efficent -}+{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-}+{-- | Parser for the lambda AST built of parsec. Converts to an intermediate format for antiexpressions -} module Language.Lambda.Parser where-import Text.Parsec +import Text.Parsec+import Text.Parsec.Language+import Text.Parsec.Token import Language.Lambda.AST import Data.Functor.Identity import Data.List+import Data.Data type M = Identity -{--data AntiExpr = AntiVar String- | AntiLam String- | AntiApp String- -type Output = (Expr, Maybe AntiExpr)--}+data MetaExpr = MVar Sym+ | MApp MetaExpr MetaExpr+ | MLam Sym MetaExpr+ | AntiExpr String+ deriving(Show, Eq, Data, Typeable) -type Output = Expr+type Output = MetaExpr top_expr :: ParsecT String u M Output top_expr = do @@ -29,37 +30,47 @@ parse_expr :: ParsecT String u M Output parse_expr = try parse_aexpr <|> try parse_lambda+ <|> try parse_anti_expr parse_aexpr :: ParsecT String u M Output parse_aexpr = try parse_app <|> try parse_atom+ +parse_anti_expr :: ParsecT String u M Output+parse_anti_expr = do+ _ <- string "$"+ i <- (identifier haskell)+ return $ AntiExpr i parse_lambda :: ParsecT String u M Output parse_lambda = do _ <- char '\\'+ spaces sym <- parse_sym <?> "lambda argument" _ <- char '.'+ spaces expr <- parse_expr <?> "lambda expression"- return $ Lam sym expr+ return $ MLam sym expr parse_app :: ParsecT String u M Output parse_app = do expr_0 <- parse_atom <?> "first apply argument" spaces as <- sepBy1 parse_atom spaces <?> "other apply arguments"- return $ foldl' App expr_0 as+ return $ foldl' MApp expr_0 as parse_atom :: ParsecT String u M Output parse_atom = try (parens' parse_expr) <|> try parse_var -+ <|> try parse_anti_expr+ parse_var :: ParsecT String u M Output parse_var = do spaces sym <- parse_sym <?> "Var symbol"- return $ Var sym --parse_sym :: ParsecT String u M String+ return $ MVar sym + +parse_sym :: ParsecT String u M Sym parse_sym = many1 (alphaNum <|> char '_') <?> "symbol" parens' :: Stream s m Char => ParsecT s u m b -> ParsecT s u m b@@ -69,17 +80,16 @@ _ <- char ')' return e ----------+meta_to_expr :: MetaExpr -> Expr+meta_to_expr (MVar x) = Var x+meta_to_expr (MApp x y) = App (meta_to_expr x) (meta_to_expr y)+meta_to_expr (MLam x y) = Lam x (meta_to_expr y)+meta_to_expr (AntiExpr _) = error "meta_to_expr should not be used if the MetaExpr tree has AntiExpr" +to_meta :: Expr -> MetaExpr+to_meta (Var x) = MVar x+to_meta (App x y) = MApp (to_meta x) (to_meta y)+to_meta (Lam x y) = MLam x (to_meta y)
src/Language/Lambda/Quote.hs view
@@ -1,20 +1,16 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, DeriveDataTypeable, StandaloneDeriving #-}-module Language.Lambda.Quote where+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+module Language.Lambda.Quote (lam) where import Language.Haskell.TH.Quote import Language.Haskell.TH import Language.Lambda.Parser-import Language.Lambda.AST import Text.Parsec (runParser)-import Data.Data--deriving instance Typeable1 GExpr-deriving instance (Data a) => Data (GExpr a) ----TODO make the pattern quoter and the anti expr+import Data.Generics.Aliases+import Data.Generics.Uniplate.Data+ lam :: QuasiQuoter-lam = QuasiQuoter quoteExprExp undefined undefined undefined+lam = QuasiQuoter quoteExprExp quoteExprPat undefined undefined -parseExpr :: Monad m => (String, Int, Int) -> String -> m Expr+parseExpr :: Monad m => (String, Int, Int) -> String -> m Output parseExpr (file, line, col) s = result where result = case runParser top_expr () file s of Left err -> fail $ (show err ++ " at file " ++ file ++ " at line " ++ @@ -22,10 +18,49 @@ Right e -> return e quoteExprExp :: String -> ExpQ-quoteExprExp s = do loc <- location- let pos = (loc_filename loc,- fst (loc_start loc),- snd (loc_start loc))- parsed_expr <- parseExpr pos s- dataToExpQ (const Nothing) parsed_expr- +quoteExprExp s = do + loc <- location+ let pos = (loc_filename loc,+ fst (loc_start loc),+ snd (loc_start loc))+ parsed_expr <- parseExpr pos s+ appE (varE $ mkName "meta_to_expr") $ dataToExpQ (const Nothing `extQ` antiExprExp) parsed_expr+ +antiExprExp :: MetaExpr -> Maybe (Q Exp)+antiExprExp (AntiExpr v) = Just $ appE (varE $ mkName "to_meta") $ varE (mkName v)+antiExprExp _ = Nothing+++quoteExprPat :: String -> PatQ+quoteExprPat s = do + loc <- location+ let pos = (loc_filename loc,+ fst (loc_start loc),+ snd (loc_start loc))+ parsed_expr <- parseExpr pos s+ th_pat <- dataToPatQ (const Nothing `extQ` antiExprPat) parsed_expr+ return $ to_e th_pat where+ to_e p = transform to_e' p++ to_e' (ConP n xs) = ConP (to_expr_name n) xs+ to_e' x = x++ to_expr_name name | show name == "MVar" = mkName "Var" + to_expr_name name | show name == "MApp" = mkName "App" + to_expr_name name | show name == "MLam" = mkName "Lam"+ to_expr_name name | otherwise = name+ +antiExprPat :: MetaExpr -> Maybe (Q Pat)+antiExprPat (AntiExpr v) = Just $ varP (mkName v)+antiExprPat _ = Nothing+++++++++++