module Data.Binding.Hobbits.QQ (nuQQ) where
import Data.Binding.Hobbits.Internal (Mb(..))
import Data.Binding.Hobbits.PatternParser (parsePattern)
import Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Quote
import Control.DeepSeq
import qualified Control.Exception as CE
import qualified Data.Generics as SYB
hobbitNamesPattVar n = mkName $ "hobbit$$names" ++ (show n)
internPattVars :: TH.Name -> TH.Name -> Pat -> Pat
internPattVars mb ln = SYB.everywhere (SYB.mkT wrapVars) where
mkView p = ViewP (InfixE
(Just $ VarE 'same_ctx `AppE` VarE mb)
(VarE '(.))
(Just $ ConE 'MkMb `AppE` VarE ln)) p
wrapVars p @ (VarP _) = mkView p
wrapVars (AsP v p) = mkView (AsP v (ConP 'MkMb [WildP, p]))
wrapVars p = p
syb_rnf :: SYB.Data a => a -> ()
syb_rnf = (`seq` ()) . rnf . SYB.gmapQ syb_rnf
same_ctx :: Mb ctx a -> Mb ctx b -> Mb ctx b
same_ctx _ x = x
nuQQPatt :: String -> Q Pat
nuQQPatt str = do
mb <- newName "mb"
ln <- newName "bs"
pat <- runIO $ CE.evaluate (let x = parsePattern str in syb_rnf x `seq` x) `catch` \err ->
(error $ "error parsing string |" ++ str ++ "|: " ++ show err)
return $ AsP mb $ ConP 'MkMb [VarP ln, internPattVars mb ln pat]
nuQQ = QuasiQuoter (error "nuQQ Exp") nuQQPatt (error "nuQQ Type") (error "nuQQ Decs")