QQ.hs

{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      : Data.Binding.Hobbits.QQ
-- Copyright   : (c) 2011 Edwin Westbrook, Nicolas Frisby, and Paul Brauner
--
-- License     : BSD3
--
-- Maintainer  : emw4@rice.edu
-- Stability   : experimental
-- Portability : GHC
--
-- Defines a quasi-quoter for writing patterns that match the bodies
-- of 'Mb' multi-bindings. Uses the
-- "Data.Binding.Hobbits.PatternParser" module, and thus only supports
-- the pattern forms listed there. If @P@ is a (supported) Haskell
-- pattern, then @[nuQQ| P ]@ defines a pattern that will match an
-- multi-binding whose body matches @P@. Any variables matched by @P@
-- will remain inside the binding; thus, for example, in the pattern
-- @[nuQQ| x |]@, @x@ matches the entire multi-binding.
--
-- Examples:
--
-- > case (nu Left) of [nuQQ| Left x |] -> x  ==  nu id
--

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

------------------------------------------------------------
-- matching under binders using a quasi-quoter
------------------------------------------------------------

hobbitNamesPattVar n = mkName $ "hobbit$$names" ++ (show n)

-- internPattVars replaces all subterms (VarP "x") with (MkMb ln -> VarP "x")
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")