LambdaPrettyQuote 0.0.0.2 → 0.0.0.6
raw patch · 3 files changed
+109/−60 lines, 3 files
Files
- LambdaPrettyQuote.cabal +5/−2
- src/Language/Lambda/Parser.hs +60/−36
- src/Language/Lambda/Quote.hs +44/−22
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.2+Version: 0.0.0.6 -- A short (one-line) description of the package. Synopsis: Parser, pretty printer, quasiquoter, and Arbitrary helpers for the untyped lambda calculus.@@ -16,7 +16,10 @@ -- A longer description of the package. Description: - CHANGES -- 0.0.0.2 added \"anti\" expressions for the quasiquoter to capture variables from the environment. Also added a pattern quasiquoter. + 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
src/Language/Lambda/Parser.hs view
@@ -11,65 +11,89 @@ type M = Identity -data MetaExpr = MVar Sym- | MApp MetaExpr MetaExpr- | MLam Sym MetaExpr+data MetaExpr s = MVar (MetaSym s)+ | MApp (MetaExpr s) (MetaExpr s)+ | MLam (MetaSym s) (MetaExpr s) | AntiExpr String+ | AntiVar String deriving(Show, Eq, Data, Typeable)+ +data MetaSym s = S s+ | AntiSym String+ deriving(Show, Eq, Data, Typeable) -type Output = MetaExpr+type Output s = MetaExpr s -top_expr :: ParsecT String u M Output-top_expr = do +type SymParser u s = ParsecT String u M s++top_expr :: SymParser u s -> ParsecT String u M (Output s)+top_expr sp = do spaces- e <- parse_expr+ e <- parse_expr sp spaces eof return e -parse_expr :: ParsecT String u M Output-parse_expr = try parse_aexpr - <|> try parse_lambda+parse_expr :: SymParser u s -> ParsecT String u M (Output s)+parse_expr sp = try (parse_aexpr sp)+ <|> try (parse_lambda sp) <|> try parse_anti_expr -parse_aexpr :: ParsecT String u M Output-parse_aexpr = try parse_app - <|> try parse_atom+parse_aexpr :: SymParser u s -> ParsecT String u M (Output s)+parse_aexpr sp = try (parse_app sp)+ <|> try (parse_atom sp) -parse_anti_expr :: ParsecT String u M Output+parse_anti_expr :: ParsecT String u M (Output s) parse_anti_expr = do _ <- string "$" i <- (identifier haskell) return $ AntiExpr i -parse_lambda :: ParsecT String u M Output-parse_lambda = do+parse_lambda :: SymParser u s -> ParsecT String u M (Output s)+parse_lambda sp = do _ <- char '\\' spaces- sym <- parse_sym <?> "lambda argument"+ sym <- (p_sym sp) <?> "lambda argument" _ <- char '.' spaces- expr <- parse_expr <?> "lambda expression"+ expr <- (parse_expr sp) <?> "lambda expression" return $ MLam sym expr -parse_app :: ParsecT String u M Output-parse_app = do- expr_0 <- parse_atom <?> "first apply argument"+parse_app :: SymParser u s -> ParsecT String u M (Output s)+parse_app sp = do+ expr_0 <- (parse_atom sp) <?> "first apply argument" spaces- as <- sepBy1 parse_atom spaces <?> "other apply arguments"+ as <- sepBy1 (parse_atom sp) spaces <?> "other apply arguments" return $ foldl' MApp expr_0 as -parse_atom :: ParsecT String u M Output-parse_atom = try (parens' parse_expr)- <|> try parse_var +parse_atom :: SymParser u s -> ParsecT String u M (Output s)+parse_atom sp = try (parens' (parse_expr sp))+ <|> try (parse_var sp) <|> try parse_anti_expr -parse_var :: ParsecT String u M Output-parse_var = do+parse_var sp = try (parse_var' sp) <|> parse_anti_var + +parse_var' :: SymParser u s -> ParsecT String u M (Output s)+parse_var' sp = do spaces- sym <- parse_sym <?> "Var symbol"- return $ MVar sym + sym <- (p_sym sp) <?> "Var symbol"+ return $ MVar sym + +parse_anti_var = do + spaces + _ <- string "*"+ i <- (identifier haskell)+ return $ AntiVar i +p_sym :: SymParser u s -> ParsecT String u M (MetaSym s)+p_sym sp = try (S `fmap` sp) <|> try parse_anti_sym++parse_anti_sym :: ParsecT String u M (MetaSym s)+parse_anti_sym = do+ _ <- string "^"+ i <- (identifier haskell)+ return $ AntiSym i+ parse_sym :: ParsecT String u M Sym parse_sym = many1 (alphaNum <|> char '_') <?> "symbol" @@ -80,16 +104,16 @@ _ <- char ')' return e -meta_to_expr :: MetaExpr -> Expr-meta_to_expr (MVar x) = Var x+meta_to_expr :: MetaExpr s -> GExpr s+meta_to_expr (MVar (S 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"+meta_to_expr (MLam (S x) y) = Lam x (meta_to_expr y)+meta_to_expr _ = 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 :: GExpr s -> MetaExpr s+to_meta (Var x) = MVar (S x) to_meta (App x y) = MApp (to_meta x) (to_meta y)-to_meta (Lam x y) = MLam x (to_meta y)+to_meta (Lam x y) = MLam (S x) (to_meta y)
src/Language/Lambda/Quote.hs view
@@ -1,58 +1,80 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}-module Language.Lambda.Quote (lam) where+{-# LANGUAGE TemplateHaskell, QuasiQuotes, RankNTypes #-}+module Language.Lambda.Quote (lam, g_lam) where import Language.Haskell.TH.Quote import Language.Haskell.TH import Language.Lambda.Parser import Text.Parsec (runParser) import Data.Generics.Aliases import Data.Generics.Uniplate.Data+import Language.Lambda.AST+import Data.Data+import Debug.Trace.Helpers lam :: QuasiQuoter-lam = QuasiQuoter quoteExprExp quoteExprPat undefined undefined+lam = g_lam parse_sym -parseExpr :: Monad m => (String, Int, Int) -> String -> m Output-parseExpr (file, line, col) s = result where- result = case runParser top_expr () file s of+g_lam :: (Data s, Show s) => SymParser () s -> QuasiQuoter+g_lam sp = QuasiQuoter (g_quoteExprExp sp) (g_quoteExprPat sp) undefined undefined+++parseExpr :: Monad m => SymParser () s -> (String, Int, Int) -> String -> m (Output s)+parseExpr sp (file, line, col) s = result where+ result = case runParser (top_expr sp) () file s of Left err -> fail $ (show err ++ " at file " ++ file ++ " at line " ++ show line ++ " at col " ++ show col) Right e -> return e -quoteExprExp :: String -> ExpQ-quoteExprExp s = do ++ +g_quoteExprExp :: (Data s, Show s, Typeable s) => SymParser () s -> String -> ExpQ+g_quoteExprExp sp r = 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+ parsed_expr <- (parseExpr sp) pos r+ appE (varE $ mkName "meta_to_expr") $ dataToExpQ (const Nothing `extQ` + (antiExprExp sp)) $ parsed_expr -antiExprExp :: MetaExpr -> Maybe (Q Exp)-antiExprExp (AntiExpr v) = Just $ appE (varE $ mkName "to_meta") $ varE (mkName v)-antiExprExp _ = Nothing-+antiExprExp :: (Data s, Typeable s) => SymParser () s -> MetaExpr s -> Maybe (Q Exp)+antiExprExp d (MLam (AntiSym v) x) = Just $ appE (appE (conE $ mkName "MLam") $ appE (conE $ mkName "S") $ varE (mkName v))+ $ dataToExpQ (const Nothing `extQ` (antiExprExp d)) x+antiExprExp d (MVar (AntiSym v)) = Just $ appE (conE $ mkName "MVar") $ appE (conE $ mkName "S") $ varE (mkName v)+antiExprExp d (AntiExpr v) = Just $ appE (varE $ mkName "to_meta") $ varE (mkName v)+antiExprExp d (AntiVar v) = Just $ [| MVar (S $(varE $ mkName v)) |]+antiExprExp _ _ = Nothing -quoteExprPat :: String -> PatQ-quoteExprPat s = do +g_quoteExprPat :: (Data s, Show s, Typeable s) => SymParser () s -> String -> PatQ+g_quoteExprPat sp r = 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+ parsed_expr <- (parseExpr sp) pos r+ th_pat <- dataToPatQ (const Nothing `extQ` (antiExprPat sp)) 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' (ConP n xs) | show n == "MVar" = ConP (to_expr_name n) [collapse_meta_sym $ head xs]+ to_e' (ConP n xs) | show n == "MLam" = ConP (to_expr_name n) ((collapse_meta_sym $ head xs):(tail xs))+ to_e' (ConP n xs) | otherwise = 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+ + collapse_meta_sym (ConP n xs) | nameBase n == "S" = head xs+ collapse_meta_sym p@(ConP n xs) | otherwise = error ("collapse_meta_sym not used on a S " ++ show p) -antiExprPat :: MetaExpr -> Maybe (Q Pat)-antiExprPat (AntiExpr v) = Just $ varP (mkName v)-antiExprPat _ = Nothing+antiExprPat :: (Data s, Typeable s) => SymParser () s -> MetaExpr s -> Maybe (Q Pat)+antiExprPat d (MLam (AntiSym v) x) = Just $ conP (mkName "MLam") [conP (mkName "S") [varP (mkName v)], + dataToPatQ (const Nothing `extQ` (antiExprPat d)) x]+antiExprPat d (MVar (AntiSym v)) = Just $ conP (mkName "MVar") [conP (mkName "S") [varP (mkName v)]]+antiExprPat d (AntiExpr v) = Just $ varP (mkName v)+antiExprPat d (AntiVar v) = Just $ conP (mkName "MVar") [conP (mkName "S") [varP $ mkName v]]+antiExprPat _ _ = Nothing