content: {-# LANGUAGE TemplateHaskell, FlexibleInstances #-}
  module Quote (t,ts,c,pl) where
  
  import Control.Applicative ((<*))
  import Data.Functor.Identity (Identity)
  
  import Language.Haskell.TH (listE, varE, viewP, mkName, Q, Exp, Pat)
  import Language.Haskell.TH.Syntax (Lift(lift))
  import Language.Haskell.TH.Lift (deriveLiftMany)
  import Language.Haskell.TH.Quote (QuasiQuoter(..))
  import Text.Parsec (parse, eof, ParsecT)
  import Data.Generics (extQ, typeOf, Data)
  
  import Prolog ( Term(..), VariableName, Clause(..), Goal
                , term, terms, clause, program, whitespace
                )
  
  $(deriveLiftMany [''Term, ''VariableName, ''Clause])
  
  instance Lift ([Term] -> [Goal]) where
     lift _ = fail "Clauses using Haskell functions can't be lifted."
  
  
  t  = prologQuasiQuoter term    "term"
  ts = prologQuasiQuoter terms   "term list"
  c  = prologQuasiQuoter clause  "clause"
  pl = prologQuasiQuoter program "program"
  
  prologQuasiQuoter parser name =
     QuasiQuoter { quoteExp  = parsePrologExp parser name
                 , quotePat  = parsePrologPat parser name
                 , quoteType = fail ("Prolog "++ name ++"s can't be Haskell types!")
                 , quoteDec  = fail ("Prolog "++ name ++"s can't be Haskell declarations!")
                 }
  
  parsePrologExp :: (Data a, Lift a) => ParsecT [Char] () Identity a -> String -> String -> Q Exp
  parsePrologExp parser name str = do
     case parse (whitespace >> parser <* eof) ("(Prolog " ++ name ++ " expression)") str of
        Right x -> const (fail $ "Quasi-quoted expressions of type " ++ show (typeOf x) ++ " are not implemented.")
            `extQ` unquote                     -- Term
            `extQ` (listE . map unquote)       -- [Term]
            `extQ` unquoteClause               -- Clause
            `extQ` (listE . map unquoteClause) -- [Clause]
             $ x
        Left e -> fail (show e)
    where
     unquote (Struct "$" [Struct var []]) =
                               [e| Struct (show $(varE (mkName var))) [] |]
     unquote (Struct "$" _)  = fail "Found '$' with non-unquotable arguments"
     unquote (Struct a   ts) = [e| Struct a $(listE $ map unquote ts) |]
     unquote t               = lift t
  
     unquoteClause (Clause lhs rhs) =
        [e| Clause $(unquote lhs) $(listE $ map unquote rhs) |]
     unquoteClause (ClauseFn _ _) =
        fail "Clauses using Haskell functions are not quasi-quotable."
  
  
  parsePrologPat :: (Data a, Lift a) => ParsecT [Char] () Identity a -> String -> String -> Q Pat
  parsePrologPat parser name str = do
     case parse (whitespace >> parser <* eof) ("(Prolog " ++ name ++ " pattern)") str of
        Right x -> viewP [e| (== $(lift x)) |] [p| True |]
  