module Data.Binding.Hobbits.QQ (nuP, clP, clNuP) where
import qualified Data.Binding.Hobbits.InternalUtilities as IU
import Data.Binding.Hobbits.Internal (Mb(..), Cl(..))
import Data.Binding.Hobbits.PatternParser (parsePattern)
import Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Ppr as TH
import Language.Haskell.TH.Quote
import qualified Data.Generics as SYB
import Control.Monad.Writer (runWriterT, tell)
import Data.Monoid (Any(..))
compose :: Exp -> Exp -> Exp
compose f g = VarE '(.) `AppE` f `AppE` g
patQQ n pat = QuasiQuoter (err "Exp") pat (err "Type") (err "Decs")
where err s = error $ "QQ `" ++ n ++ "' is for patterns, not " ++ s ++ "."
data WrapKit =
WrapKit {_add :: Exp, _rm :: Pat -> Pat, _top :: Bool -> Pat -> Pat}
outsideKit (WrapKit {_add = addO, _rm = rmO, _top = topO})
(WrapKit {_add = addI, _rm = rmI, _top = topI}) =
WrapKit {_add = addO `compose` addI,
_rm = rmO . rmI,
_top = \b -> topO b . topI b}
wrapVars :: Monad m => WrapKit -> Pat -> m Pat
wrapVars (WrapKit {_add = add, _rm = rm, _top = top}) pat = do
(pat', Any usedAdd) <- runWriterT m
return $ top usedAdd pat'
where
m = IU.everywhereButM (SYB.mkQ False isExp) (SYB.mkM w) pat
where isExp :: Exp -> Bool
isExp _ = True
hit x = tell (Any True) >> return x
w p@VarP{} = hit $ ViewP add p
w (AsP v p) = hit $ ViewP add $ AsP v $ rm p
w (ViewP (VarE n) p) = return $ ViewP (VarE 'unCl `AppE` VarE n) p
w (ViewP e _) = fail $ "view function must be a single name: `" ++ show (TH.ppr e) ++ "'"
w p = return p
parseHere :: String -> Q Pat
parseHere s = do
fn <- loc_filename `fmap` location
case parsePattern fn s of
Left e -> error $ "Parse error: `" ++ e ++
"'\n\n\t when parsing pattern: `" ++ s ++ "'."
Right p -> return p
same_ctx :: Mb ctx a -> Mb ctx b -> Mb ctx b
same_ctx _ x = x
nuKit mb ln = WrapKit {_add = add, _rm = rm, _top = top} where
add = (VarE 'same_ctx `AppE` VarE mb) `compose`
(ConE 'MkMb `AppE` VarE ln)
rm p = ConP 'MkMb [WildP, p]
top b p = if b then AsP mb $ ConP 'MkMb [VarP ln, p] else rm p
nuP = patQQ "nuP" $ \s -> do
mb <- newName "mb"
ln <- newName "bs"
parseHere s >>= wrapVars (nuKit mb ln)
clKit = WrapKit {_add = ConE 'Cl, _rm = rm, _top = const rm}
where rm p = ConP 'Cl [p]
clP = patQQ "clP" $ (>>= wrapVars clKit) . parseHere
clNuP = patQQ "clNuP" $ \s -> do
mb <- newName "mb"
ln <- newName "bs"
parseHere s >>= wrapVars (clKit `outsideKit` nuKit mb ln)