{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Control.Egison.QQ (
mc,
) where
import Control.Egison.Core
import Data.List
import Data.List.Split
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Language.Haskell.Meta
import Language.Haskell.TH hiding (match)
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Text.Regex
mc :: QuasiQuoter
mc = QuasiQuoter { quoteExp = \s -> do
let [pat, exp] = splitOn "=>" s
e1 <- case parseExp (changeNotPat (changeOrPat (changeAndPat (changeValuePat (changePatVar (changeWildcard pat)))))) of
Left _ -> fail "Could not parse pattern expression."
Right exp -> return exp
e2 <- case parseExp exp of
Left _ -> fail "Could not parse expression."
Right exp -> return exp
mcChange e1 e2
, quotePat = undefined
, quoteType = undefined
, quoteDec = undefined }
changeWildcard :: String -> String
changeWildcard pat = subRegex (mkRegex " _") pat " Wildcard"
changePatVar :: String -> String
changePatVar pat = subRegex (mkRegex "\\$([a-zA-Z0-9]+)") pat "(PatVar \"\\1\")"
changeValuePat :: String -> String
changeValuePat pat = subRegex (mkRegex "\\#(\\([^)]+\\)|\\[[^)]+\\]|[a-zA-Z0-9]+)") pat "(valuePat \\1)"
changeAndPat :: String -> String
changeAndPat pat = subRegex (mkRegex "\\(\\&") pat "(AndPat"
changeOrPat :: String -> String
changeOrPat pat = subRegex (mkRegex "\\(\\|") pat "(OrPat"
changeNotPat :: String -> String
changeNotPat pat = subRegex (mkRegex "\\(not ") pat "(NotPat "
mcChange :: Exp -> Exp -> Q Exp
mcChange pat expr = do
let (vars, xs) = extractPatVars [pat] []
[| (MatchClause $(fst <$> changePat pat (map (`take` vars) xs)) $(changeExp vars expr)) |]
extractPatVars :: [Exp] -> [String] -> ([String], [Int])
extractPatVars [] vars = (vars, [])
extractPatVars (ParensE x:xs) vars = extractPatVars (x:xs) vars
extractPatVars (AppE (ConE name) p:xs) vars
| nameBase name == "PatVar" = case p of (LitE (StringL s)) -> extractPatVars xs (vars ++ [s])
| nameBase name == "PredicatePat" = let (vs, ns) = extractPatVars xs vars in (vs, length vars:ns)
| nameBase name == "LaterPat" =
let (vs1, ns1) = extractPatVars xs vars in
let (vs2, ns2) = extractPatVars [p] vs1 in (vs2, ns2 ++ ns1)
| otherwise = extractPatVars (p:xs) vars
extractPatVars (AppE (VarE name) p:xs) vars
| nameBase name == "valuePat" = let (vs, ns) = extractPatVars xs vars in (vs, length vars:ns)
| otherwise = extractPatVars (p:xs) vars
extractPatVars (AppE a b:xs) vars = extractPatVars (a:b:xs) vars
extractPatVars (SigE x typ:xs) vs = extractPatVars (x:xs) vs
extractPatVars (_:xs) vars = extractPatVars xs vars
changePat :: Exp -> [[String]] -> Q (Exp, [[String]])
changePat e@(AppE (ConE name) p) vs
| nameBase name == "PredicatePat" = do
let (vars:varss) = vs
(, varss) <$> appE (conE 'PredicatePat) (changeExp vars p)
| otherwise = do
(e', vs') <- changePat p vs
(, vs') <$> appE (conE name) (return e')
changePat e@(AppE (VarE name) p) vs
| nameBase name == "valuePat" = do
let (vars:varss) = vs
(, varss) <$> appE (varE name) (changeExp vars p)
| otherwise = do
(e', vs') <- changePat p vs
(, vs') <$> appE (varE name) (return e')
changePat (AppE e1 e2) vs = do
(e1', vs') <- changePat e1 vs
(e2', vs'') <- changePat e2 vs'
(, vs'') <$> appE (return e1') (return e2')
changePat (ParensE x) vs = changePat x vs
changePat (SigE x typ) vs = changePat x vs
changePat e vs = return (e, vs)
changeExp :: [String] -> Exp -> Q Exp
changeExp vars expr = do
vars' <- mapM newName vars
vars'' <- mapM (\s -> newName $ s ++ "'") vars
return $ LamE [f vars'] expr
f :: [Name] -> Pat
f [] = ConP 'HNil []
f (x:xs) = InfixP (VarP x) 'HCons $ f xs