content: -- |
  -- Module      :  Language.C.Quote
  -- Copyright   :  (c) 2006-2011 Harvard University
  --                (c) 2011-2013 Geoffrey Mainland
  --             :  (c) 2013-2017 Drexel University
  -- License     :  BSD-style
  -- Maintainer  :  mainland@drexel.edu
  
  {-# LANGUAGE CPP #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE TemplateHaskell #-}
  {-# OPTIONS_GHC -w #-}
  
  module Language.C.Quote.Base (
      ToIdent(..),
      ToConst(..),
      ToExp(..),
      qqExp,
      qqPat,
      quasiquote
    ) where
  
  import Control.Monad ((>=>))
  import qualified Data.ByteString.Char8 as B
  import Data.Char (isAscii, isPrint, ord)
  import Data.Data (Data(..))
  import Data.Generics (extQ)
  import Data.Int
  import Data.Loc
  import Data.Typeable (Typeable(..))
  import Data.Word
  #ifdef FULL_HASKELL_ANTIQUOTES
  import Language.Haskell.Meta (parseExp,parsePat)
  #else
  import Language.Haskell.ParseExp (parseExp,parsePat)
  #endif
  import Language.Haskell.TH as TH
  #if MIN_VERSION_template_haskell(2,7,0)
  import Language.Haskell.TH.Quote (QuasiQuoter(..),
                                    dataToQa,
                                    dataToExpQ,
                                    dataToPatQ)
  #else /* !MIN_VERSION_template_haskell(2,7,0) */
  import Language.Haskell.TH.Quote (QuasiQuoter(..))
  #endif /* !MIN_VERSION_template_haskell(2,7,0) */
  import Language.Haskell.TH.Syntax
  import Numeric (showOct, showHex)
  
  import qualified Language.C.Parser as P
  import qualified Language.C.Syntax as C
  
  newtype LongDouble = LongDouble Double
  
  -- | An instance of 'ToIndent' can be converted to a 'C.Id'.
  class ToIdent a where
      toIdent :: a -> SrcLoc -> C.Id
  
  instance ToIdent C.Id where
      toIdent ident _ = ident
  
  instance ToIdent (SrcLoc -> C.Id) where
      toIdent ident = ident
  
  instance ToIdent String where
      toIdent s loc = C.Id s loc
  
  -- | An instance of 'ToConst' can be converted to a 'C.Const'.
  class ToConst a where
      toConst :: a -> SrcLoc -> C.Const
  
  instance ToConst C.Const where
      toConst k _ = k
  
  instance ToConst Int where
      toConst = toConst . toInteger
  
  instance ToConst Int8 where
      toConst = toConst . toInteger
  
  instance ToConst Int16 where
      toConst = toConst . toInteger
  
  instance ToConst Int32 where
      toConst = toConst . toInteger
  
  instance ToConst Int64 where
      toConst = toConst . toInteger
  
  instance ToConst Word where
      toConst n loc = C.IntConst (show n) C.Unsigned (toInteger n) loc
  
  instance ToConst Word8 where
      toConst n loc = C.IntConst (show n) C.Unsigned (toInteger n) loc
  
  instance ToConst Word16 where
      toConst n loc = C.IntConst (show n) C.Unsigned (toInteger n) loc
  
  instance ToConst Word32 where
      toConst n loc = C.IntConst (show n) C.Unsigned (toInteger n) loc
  
  instance ToConst Word64 where
      toConst n loc = C.IntConst (show n) C.Unsigned (toInteger n) loc
  
  instance ToConst Integer where
      toConst n loc = C.IntConst (show n) C.Signed n loc
  
  instance ToConst Rational where
      toConst n loc = toConst (fromRational n :: Double) loc
  
  instance ToConst Float where
      toConst n loc = C.FloatConst (realFloatToString n ++ "F") n loc
  
  instance ToConst Double where
      toConst n loc = C.DoubleConst (realFloatToString n) n loc
  
  instance ToConst LongDouble where
      toConst (LongDouble n) loc = C.LongDoubleConst (realFloatToString n ++ "L") n loc
  
  realFloatToString :: (RealFloat a, Show a) => a -> String
  realFloatToString n
    | isNaN n      = "NAN"
    | isInfinite n = if n < 0 then "-INFINITY" else "INFINITY"
    | otherwise    = show n
  
  instance ToConst Char where
      toConst c loc = C.CharConst ("'" ++ charToString c ++ "'") c loc
        where
          charToString :: Char -> String
          charToString '\0' = "\\0"
          charToString '\a' = "\\a"
          charToString '\b' = "\\b"
          charToString '\f' = "\\f"
          charToString '\n' = "\\n"
          charToString '\r' = "\\r"
          charToString '\t' = "\\t"
          charToString '\v' = "\\v"
          charToString '\\' = "\\\\"
          charToString '\"' = "\\\""
          charToString c
            | isAscii c && isPrint c = [c]
            | isAscii c              = "\\x" ++ hexOf Nothing c
            | ord c < 0x10000        = "\\u" ++ hexOf (Just 4) c
            | otherwise              = "\\U" ++ hexOf (Just 8) c
            where
              hexOf :: Maybe Int -> Char -> String
              hexOf len c = case len of
                              Nothing -> hex
                              Just i  -> replicate (i - length hex) '0' ++ hex
                where
                  hex :: String
                  hex = showHex (ord c) ""
  
  instance ToConst String where
      toConst s loc = C.StringConst [show s] s loc
  
  -- | An instance of 'ToExp' can be converted to a 'C.Exp'.
  class ToExp a where
      toExp :: a -> SrcLoc -> C.Exp
  
  instance ToExp C.Exp where
      toExp e _ = e
  
  instance ToExp Int where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Int8 where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Int16 where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Int32 where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Int64 where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Word where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Word8 where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Word16 where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Word32 where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Word64 where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Integer where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Rational where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Float where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Double where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp Char where
      toExp n loc = C.Const (toConst n loc) loc
  
  instance ToExp String where
      toExp n loc = C.Const (toConst n loc) loc
  
  antiVarE :: String -> ExpQ
  antiVarE = either fail return . parseExp
  
  qqLocE :: SrcLoc -> ExpQ
  qqLocE loc = dataToExpQ qqExp loc
  
  qqStringE :: String -> Maybe (Q Exp)
  qqStringE s = Just $ litE $ stringL s
  
  qqIdE :: C.Id -> Maybe (Q Exp)
  qqIdE (C.AntiId v loc)  = Just [|toIdent $(antiVarE v) $(qqLocE loc)|]
  qqIdE _                 = Nothing
  
  qqDeclSpecE :: C.DeclSpec -> Maybe (Q Exp)
  qqDeclSpecE (C.AntiDeclSpec v _) = Just $ antiVarE v
  qqDeclSpecE (C.AntiTypeDeclSpec extraStorage extraTypeQuals v _) =
      Just [|
          case $(antiVarE v) of
              C.Type (C.DeclSpec storage typeQuals typeSpec loc) _ _ ->
                   C.DeclSpec
                       (storage ++ $(dataToExpQ qqExp extraStorage))
                       (typeQuals ++ $(dataToExpQ qqExp extraTypeQuals))
                       typeSpec
                       loc
  
              x -> error
                     $ "Impossible happened, expected C.Type (C.DeclSpec {}) but got "
                     ++ show x
           |]
  qqDeclSpecE _ = Nothing
  
  qqDeclE :: C.Decl -> Maybe (Q Exp)
  qqDeclE (C.AntiTypeDecl v _) =
      Just [|
          case $(antiVarE v) of
              C.Type _ decl _ -> decl
              x -> error
                     $ "Impossible happened, expected C.Type but got "
                     ++ show x
      |]
  qqDeclE _ = Nothing
  
  qqTypeQualE :: C.TypeQual -> Maybe (Q Exp)
  qqTypeQualE (C.AntiTypeQual v _)  = Just $ antiVarE v
  qqTypeQualE _                     = Nothing
  
  qqTypeQualListE :: [C.TypeQual] -> Maybe (Q Exp)
  qqTypeQualListE [] = Just [|[]|]
  qqTypeQualListE (C.AntiTypeQuals v _ : stms) =
      Just [|$(antiVarE v) ++ $(dataToExpQ qqExp stms)|]
  qqTypeQualListE (stm : stms) =
      Just [|$(dataToExpQ qqExp stm) : $(dataToExpQ qqExp stms)|]
  
  qqTypeE :: C.Type -> Maybe (Q Exp)
  qqTypeE (C.AntiType v _)  = Just $ antiVarE v
  qqTypeE _                 = Nothing
  
  qqInitializerE :: C.Initializer -> Maybe (Q Exp)
  qqInitializerE (C.AntiInit v _)  = Just $ antiVarE v
  qqInitializerE _                 = Nothing
  
  qqInitializerListE :: [(Maybe C.Designation, C.Initializer)] -> Maybe (Q Exp)
  qqInitializerListE [] = Just [|[]|]
  qqInitializerListE ((Nothing, C.AntiInits v _) : fields) =
      Just [|[(Nothing, init) | init <- $(antiVarE v)] ++ $(dataToExpQ qqExp fields)|]
  qqInitializerListE (field : fields) =
      Just [|$(dataToExpQ qqExp field) : $(dataToExpQ qqExp fields)|]
  
  qqInitGroupE :: C.InitGroup -> Maybe (Q Exp)
  qqInitGroupE (C.AntiDecl v _)  = Just $ antiVarE v
  qqInitGroupE _                 = Nothing
  
  qqInitGroupListE :: [C.InitGroup] -> Maybe (Q Exp)
  qqInitGroupListE [] = Just [|[]|]
  qqInitGroupListE (C.AntiDecls v _ : inits) =
      Just [|$(antiVarE v) ++ $(dataToExpQ qqExp inits)|]
  qqInitGroupListE (ini : inis) =
      Just [|$(dataToExpQ qqExp ini) : $(dataToExpQ qqExp inis)|]
  
  qqAttrE :: C.Attr -> Maybe (Q Exp)
  qqAttrE (C.AntiAttr v _)  = Just $ antiVarE v
  qqAttrE _                 = Nothing
  
  qqAttrListE :: [C.Attr] -> Maybe (Q Exp)
  qqAttrListE [] = Just [|[]|]
  qqAttrListE (C.AntiAttrs v _ : attrs) =
      Just [|$(antiVarE v) ++ $(dataToExpQ qqExp attrs)|]
  qqAttrListE (field : fields) =
      Just [|$(dataToExpQ qqExp field) : $(dataToExpQ qqExp fields)|]
  
  qqFieldGroupE :: C.FieldGroup -> Maybe (Q Exp)
  qqFieldGroupE (C.AntiSdecl v _)  = Just $ antiVarE v
  qqFieldGroupE _                  = Nothing
  
  qqFieldGroupListE :: [C.FieldGroup] -> Maybe (Q Exp)
  qqFieldGroupListE [] = Just [|[]|]
  qqFieldGroupListE (C.AntiSdecls v _ : fields) =
      Just [|$(antiVarE v) ++ $(dataToExpQ qqExp fields)|]
  qqFieldGroupListE (field : fields) =
      Just [|$(dataToExpQ qqExp field) : $(dataToExpQ qqExp fields)|]
  
  qqCEnumE :: C.CEnum -> Maybe (Q Exp)
  qqCEnumE (C.AntiEnum v _)  = Just $ antiVarE v
  qqCEnumE _                 = Nothing
  
  qqCEnumListE :: [C.CEnum] -> Maybe (Q Exp)
  qqCEnumListE [] = Just [|[]|]
  qqCEnumListE (C.AntiEnums v _ : fields) =
      Just [|$(antiVarE v) ++ $(dataToExpQ qqExp fields)|]
  qqCEnumListE (field : fields) =
      Just [|$(dataToExpQ qqExp field) : $(dataToExpQ qqExp fields)|]
  
  qqParamE :: C.Param -> Maybe (Q Exp)
  qqParamE (C.AntiParam v _)  = Just $ antiVarE v
  qqParamE _                  = Nothing
  
  qqParamListE :: [C.Param] -> Maybe (Q Exp)
  qqParamListE [] = Just [|[]|]
  qqParamListE (C.AntiParams v _ : args) =
      Just [|$(antiVarE v) ++ $(dataToExpQ qqExp args)|]
  qqParamListE (arg : args) =
      Just [|$(dataToExpQ qqExp arg) : $(dataToExpQ qqExp args)|]
  
  qqDefinitionE :: C.Definition -> Maybe (Q Exp)
  qqDefinitionE (C.AntiFunc v loc) =
      Just [|C.FuncDef $(antiVarE v) $(qqLocE loc)|]
  qqDefinitionE (C.AntiEsc v loc) =
      Just [|C.EscDef $(antiVarE v) $(qqLocE loc)|]
  qqDefinitionE (C.AntiEdecl v _) =
      Just $ antiVarE v
  qqDefinitionE (C.AntiObjCMeth m _) =
      Just $ antiVarE m
  qqDefinitionE _ = Nothing
  
  qqDefinitionListE :: [C.Definition] -> Maybe (Q Exp)
  qqDefinitionListE [] = Just [|[]|]
  qqDefinitionListE (C.AntiEdecls v _ : defs) =
      Just [|$(antiVarE v) ++ $(dataToExpQ qqExp defs)|]
  qqDefinitionListE (C.AntiObjCMeths m _ : meths) =
      Just [|$(antiVarE m) ++ $(dataToExpQ qqExp meths)|]
  qqDefinitionListE (def : defs) =
      Just [|$(dataToExpQ qqExp def) : $(dataToExpQ qqExp defs)|]
  
  qqConstE :: C.Const -> Maybe (Q Exp)
  qqConstE = go
    where
      go (C.AntiConst v loc) =
          Just [|toConst $(antiVarE v) $(qqLocE loc) :: C.Const|]
  
      go (C.AntiInt v loc) =
          Just [|C.IntConst  $(intConst (antiVarE v)) C.Signed
                             (fromIntegral $(antiVarE v))
                             $(qqLocE loc)|]
  
      go (C.AntiUInt v loc) =
          Just [|C.IntConst  ($(intConst (antiVarE v)) ++ "U") C.Unsigned
                             (fromIntegral $(antiVarE v))
                             $(qqLocE loc)|]
  
      go (C.AntiLInt v loc) =
          Just [|C.LongIntConst  ($(intConst (antiVarE v)) ++ "L") C.Signed
                                 (fromIntegral $(antiVarE v))
                                 $(qqLocE loc)|]
  
      go (C.AntiULInt v loc) =
          Just [|C.LongIntConst  ($(intConst (antiVarE v)) ++ "UL") C.Unsigned
                                 (fromIntegral $(antiVarE v))
                                 $(qqLocE loc)|]
  
      go (C.AntiLLInt v loc) =
          Just [|C.LongLongIntConst  ($(intConst (antiVarE v)) ++ "LL") C.Signed
                                 (fromIntegral $(antiVarE v))
                                 $(qqLocE loc)|]
  
      go (C.AntiULLInt v loc) =
          Just [|C.LongLongIntConst  ($(intConst (antiVarE v)) ++ "ULL") C.Unsigned
                                 (fromIntegral $(antiVarE v))
                                 $(qqLocE loc)|]
  
      go (C.AntiFloat v loc) =
          Just [|toConst ($(antiVarE v) :: Float) $(qqLocE loc)|]
  
      go (C.AntiDouble v loc) =
          Just [|toConst ($(antiVarE v) :: Double) $(qqLocE loc)|]
  
      go (C.AntiLongDouble v loc) =
          Just [|toConst (LongDouble $(antiVarE v)) $(qqLocE loc)|]
  
      go (C.AntiChar v loc) =
          Just [|toConst $(antiVarE v) $(qqLocE loc)|]
  
      go (C.AntiString v loc) =
          Just [|C.StringConst [show $(antiVarE v)] $(antiVarE v) $(qqLocE loc)|]
  
      go _ = Nothing
  
      intConst :: ExpQ -> ExpQ
      intConst e = [|show $(e)|]
  
  qqExpE :: C.Exp -> Maybe (Q Exp)
  qqExpE (C.AntiExp v loc)    = Just [|toExp $(antiVarE v) $(qqLocE loc) :: C.Exp|]
  qqExpE (C.AntiEscExp v loc) = Just [|C.EscExp $(antiVarE v) $(qqLocE loc) :: C.Exp|]
  qqExpE _                    = Nothing
  
  qqExpListE :: [C.Exp] -> Maybe (Q Exp)
  qqExpListE [] = Just [|[]|]
  qqExpListE (C.AntiArgs v loc : exps) =
      Just [|[toExp v $(qqLocE loc) | v <- $(antiVarE v)] ++
             $(dataToExpQ qqExp exps)|]
  qqExpListE (exp : exps) =
      Just [|$(dataToExpQ qqExp exp) : $(dataToExpQ qqExp exps)|]
  
  qqStmE :: C.Stm -> Maybe (Q Exp)
  qqStmE (C.AntiEscStm v loc)      = Just [|C.EscStm $(antiVarE v) $(qqLocE loc)|]
  qqStmE (C.AntiPragma v loc)      = Just [|C.Pragma $(antiVarE v) $(qqLocE loc)|]
  qqStmE (C.AntiComment v stm loc) = Just [|C.Comment $(antiVarE v) $(dataToExpQ qqExp stm) $(qqLocE loc)|]
  qqStmE (C.AntiStm v _)           = Just $ antiVarE v
  qqStmE _                         = Nothing
  
  qqStmListE :: [C.Stm] -> Maybe (Q Exp)
  qqStmListE [] = Just [|[]|]
  qqStmListE (C.AntiStms v _ : stms) =
      Just [|$(antiVarE v) ++ $(dataToExpQ qqExp stms)|]
  qqStmListE (stm : stms) =
      Just [|$(dataToExpQ qqExp stm) : $(dataToExpQ qqExp stms)|]
  
  qqBlockItemE :: C.BlockItem -> Maybe (Q Exp)
  qqBlockItemE (C.AntiBlockItem v _) = Just $ antiVarE v
  qqBlockItemE _                     = Nothing
  
  qqBlockItemListE :: [C.BlockItem] -> Maybe (Q Exp)
  qqBlockItemListE [] = Just [|[]|]
  qqBlockItemListE (C.BlockDecl (C.AntiDecls v _) : items) =
      Just [|map C.BlockDecl $(antiVarE v) ++ $(dataToExpQ qqExp items)|]
  qqBlockItemListE (C.BlockStm (C.AntiStms v _) : items) =
      Just [|map C.BlockStm $(antiVarE v) ++ $(dataToExpQ qqExp items)|]
  qqBlockItemListE (C.AntiBlockItems v _ : items) =
      Just [|$(antiVarE v) ++ $(dataToExpQ qqExp items)|]
  qqBlockItemListE (stm : stms) =
      Just [|$(dataToExpQ qqExp stm) : $(dataToExpQ qqExp stms)|]
  
  qqObjcIfaceDeclE :: C.ObjCIfaceDecl -> Maybe (Q Exp)
  qqObjcIfaceDeclE (C.AntiObjCProp p _) = Just $ antiVarE p
  qqObjcIfaceDeclE _                    = Nothing
  
  qqObjcIfaceDeclListE :: [C.ObjCIfaceDecl] -> Maybe (Q Exp)
  qqObjcIfaceDeclListE [] = Just [|[]|]
  qqObjcIfaceDeclListE (C.AntiObjCProps p _ : decls) =
      Just [|$(antiVarE p) ++ $(dataToExpQ qqExp decls)|]
  qqObjcIfaceDeclListE (C.AntiObjCIfaceDecls v _ : decls) =
      Just [|$(antiVarE v) ++ $(dataToExpQ qqExp decls)|]
  qqObjcIfaceDeclListE (C.AntiObjCIfaceDecl v _  : decls) =
      Just [|$(antiVarE v) : $(dataToExpQ qqExp decls)|]
  qqObjcIfaceDeclListE (decl : decls) =
      Just [|$(dataToExpQ qqExp decl) : $(dataToExpQ qqExp decls)|]
  
  qqObjCPropAttrE :: C.ObjCPropAttr -> Maybe (Q Exp)
  qqObjCPropAttrE (C.AntiObjCAttr pa _) = Just $ antiVarE pa
  qqObjCPropAttrE _                     = Nothing
  
  qqObjCPropAttrListE :: [C.ObjCPropAttr] -> Maybe (Q Exp)
  qqObjCPropAttrListE [] = Just [|[]|]
  qqObjCPropAttrListE (C.AntiObjCAttrs pa _:attrelems) =
      Just [|$(antiVarE pa) ++ $(dataToExpQ qqExp attrelems)|]
  qqObjCPropAttrListE (pattr : pattrs) =
      Just [|$(dataToExpQ qqExp pattr) : $(dataToExpQ qqExp pattrs)|]
  
  qqObjCDictsE :: [C.ObjCDictElem] -> Maybe (Q Exp)
  qqObjCDictsE [] = Just [|[]|]
  qqObjCDictsE (C.AntiObjCDictElems e _:elems) =
      Just [|$(antiVarE e) ++ $(dataToExpQ qqExp elems)|]
  qqObjCDictsE (elem : elems) =
      Just [|$(dataToExpQ qqExp elem) : $(dataToExpQ qqExp elems)|]
  
  qqObjCParamE :: C.ObjCParam -> Maybe (Q Exp)
  qqObjCParamE (C.AntiObjCParam p _) = Just $ antiVarE p
  qqObjCParamE _                     = Nothing
  
  qqObjCParamsE :: [C.ObjCParam] -> Maybe (Q Exp)
  qqObjCParamsE [] = Just [|[]|]
  qqObjCParamsE (C.AntiObjCParams p _: props) =
      Just [|$(antiVarE p) ++ $(dataToExpQ qqExp props)|]
  qqObjCParamsE (param : params) =
      Just [|$(dataToExpQ qqExp param) : $(dataToExpQ qqExp params)|]
  
  qqObjCMethodProtoE :: C.ObjCMethodProto -> Maybe (Q Exp)
  qqObjCMethodProtoE (C.AntiObjCMethodProto p _) = Just $ antiVarE p
  qqObjCMethodProtoE _                           = Nothing
  
  qqObjCRecvE :: C.ObjCRecv -> Maybe (Q Exp)
  qqObjCRecvE (C.AntiObjCRecv p _) = Just $ antiVarE p
  qqObjCRecvE _                  = Nothing
  
  qqObjCArgE :: C.ObjCArg -> Maybe (Q Exp)
  qqObjCArgE (C.AntiObjCArg p _) = Just $ antiVarE p
  qqObjCArgE _                  = Nothing
  
  qqObjCArgsE :: [C.ObjCArg] -> Maybe (Q Exp)
  qqObjCArgsE [] = Just [|[]|]
  qqObjCArgsE (C.AntiObjCArgs a _: args) =
      Just [|$(antiVarE a) ++ $(dataToExpQ qqExp args)|]
  qqObjCArgsE (arg : args) =
      Just [|$(dataToExpQ qqExp arg) : $(dataToExpQ qqExp args)|]
  
  qqExp :: Typeable a => a -> Maybe (Q Exp)
  qqExp = const Nothing  `extQ` qqStringE
                         `extQ` qqIdE
                         `extQ` qqDeclSpecE
                         `extQ` qqDeclE
                         `extQ` qqTypeQualE
                         `extQ` qqTypeQualListE
                         `extQ` qqTypeE
                         `extQ` qqInitializerE
                         `extQ` qqInitializerListE
                         `extQ` qqInitGroupE
                         `extQ` qqInitGroupListE
                         `extQ` qqAttrE
                         `extQ` qqAttrListE
                         `extQ` qqFieldGroupE
                         `extQ` qqFieldGroupListE
                         `extQ` qqCEnumE
                         `extQ` qqCEnumListE
                         `extQ` qqParamE
                         `extQ` qqParamListE
                         `extQ` qqDefinitionE
                         `extQ` qqDefinitionListE
                         `extQ` qqConstE
                         `extQ` qqExpE
                         `extQ` qqExpListE
                         `extQ` qqStmE
                         `extQ` qqStmListE
                         `extQ` qqBlockItemE
                         `extQ` qqBlockItemListE
                         `extQ` qqObjcIfaceDeclE
                         `extQ` qqObjcIfaceDeclListE
                         `extQ` qqObjCPropAttrE
                         `extQ` qqObjCPropAttrListE
                         `extQ` qqObjCDictsE
                         `extQ` qqObjCParamE
                         `extQ` qqObjCParamsE
                         `extQ` qqObjCMethodProtoE
                         `extQ` qqObjCRecvE
                         `extQ` qqObjCArgE
                         `extQ` qqObjCArgsE
  
  antiVarP :: String -> PatQ
  antiVarP = either fail return . parsePat
  
  qqStringP :: String -> Maybe (Q Pat)
  qqStringP s = Just $ litP $ stringL s
  
  qqLocP :: Data.Loc.Loc -> Maybe (Q Pat)
  qqLocP _ = Just wildP
  
  qqIdP :: C.Id -> Maybe (Q Pat)
  qqIdP (C.AntiId v _) = Just $ conP (mkName "C.Id") [antiVarP v, wildP]
  qqIdP _              = Nothing
  
  qqDeclSpecP :: C.DeclSpec -> Maybe (Q Pat)
  qqDeclSpecP (C.AntiDeclSpec v _) = Just $ antiVarP v
  qqDeclSpecP C.AntiTypeDeclSpec{} =
      error "Illegal antiquoted type in pattern"
  qqDeclSpecP _ = Nothing
  
  qqDeclP :: C.Decl -> Maybe (Q Pat)
  qqDeclP C.AntiTypeDecl{} =
      error "Illegal antiquoted type in pattern"
  qqDeclP _ = Nothing
  
  qqTypeQualP :: C.TypeQual -> Maybe (Q Pat)
  qqTypeQualP (C.AntiTypeQual v _) = Just $ antiVarP v
  qqTypeQualP _                    = Nothing
  
  qqTypeQualListP :: [C.TypeQual] -> Maybe (Q Pat)
  qqTypeQualListP [] = Just $ listP []
  qqTypeQualListP [C.AntiTypeQuals v _] = Just $ antiVarP v
  qqTypeQualListP (C.AntiTypeQuals{} : _ : _) =
      error "Antiquoted list of type qualifiers must be last item in quoted list"
  qqTypeQualListP (arg : args) =
      Just $ conP (mkName ":") [dataToPatQ qqPat arg, dataToPatQ qqPat args]
  
  qqTypeP :: C.Type -> Maybe (Q Pat)
  qqTypeP (C.AntiType v _)  = Just $ antiVarP v
  qqTypeP _                 = Nothing
  
  qqInitializerP :: C.Initializer -> Maybe (Q Pat)
  qqInitializerP (C.AntiInit v _)  = Just $ antiVarP v
  qqInitializerP _                 = Nothing
  
  qqInitializerListP :: [C.Initializer] -> Maybe (Q Pat)
  qqInitializerListP [] = Just $ listP []
  qqInitializerListP [C.AntiInits v _] = Just $ antiVarP v
  qqInitializerListP (C.AntiInits{} : _ : _) =
      error "Antiquoted list of initializers must be last item in quoted list"
  qqInitializerListP (ini : inis) =
      Just $ conP (mkName ":") [dataToPatQ qqPat ini,  dataToPatQ qqPat inis]
  
  qqInitGroupP :: C.InitGroup -> Maybe (Q Pat)
  qqInitGroupP (C.AntiDecl v _) = Just $ antiVarP v
  qqInitGroupP _                = Nothing
  
  qqInitGroupListP :: [C.InitGroup] -> Maybe (Q Pat)
  qqInitGroupListP [] = Just $ listP []
  qqInitGroupListP [C.AntiDecls v _] = Just $ antiVarP v
  qqInitGroupListP (C.AntiDecls{} : _ : _) =
      error "Antiquoted list of initialization groups must be last item in quoted list"
  qqInitGroupListP (ini : inis) =
      Just $ conP (mkName ":") [dataToPatQ qqPat ini,  dataToPatQ qqPat inis]
  
  qqAttrP :: C.Attr -> Maybe (Q Pat)
  qqAttrP (C.AntiAttr v _)  = Just $ antiVarP v
  qqAttrP _                 = Nothing
  
  qqAttrListP :: [C.Attr] -> Maybe (Q Pat)
  qqAttrListP [] = Just $ listP []
  qqAttrListP [C.AntiAttrs v _] = Just $ antiVarP v
  qqAttrListP (C.AntiAttrs{} : _ : _) =
     error "Antiquoted list of attrs must be last item in quoted list"
  qqAttrListP (ini : inis) =
      Just $ conP (mkName ":") [dataToPatQ qqPat ini,  dataToPatQ qqPat inis]
  
  qqFieldGroupP :: C.FieldGroup -> Maybe (Q Pat)
  qqFieldGroupP (C.AntiSdecl v _) = Just $ antiVarP v
  qqFieldGroupP _                 = Nothing
  
  qqFieldGroupListP :: [C.FieldGroup] -> Maybe (Q Pat)
  qqFieldGroupListP [] = Just $ listP []
  qqFieldGroupListP [C.AntiSdecls v _] = Just $ antiVarP v
  qqFieldGroupListP (C.AntiSdecls{} : _ : _) =
      error "Antiquoted list of struct/union fields must be last item in quoted list"
  qqFieldGroupListP (ini : inis) =
      Just $ conP (mkName ":") [dataToPatQ qqPat ini,  dataToPatQ qqPat inis]
  
  qqCEnumP :: C.CEnum -> Maybe (Q Pat)
  qqCEnumP (C.AntiEnum v _) = Just $ antiVarP v
  qqCEnumP _                = Nothing
  
  qqCEnumListP :: [C.CEnum] -> Maybe (Q Pat)
  qqCEnumListP [] = Just $ listP []
  qqCEnumListP [C.AntiEnums v _] = Just $ antiVarP v
  qqCEnumListP (C.AntiEnums{} : _ : _) =
      error "Antiquoted list of enumerations must be last item in quoted list"
  qqCEnumListP (ini : inis) =
      Just $ conP (mkName ":") [dataToPatQ qqPat ini,  dataToPatQ qqPat inis]
  
  qqParamP :: C.Param -> Maybe (Q Pat)
  qqParamP (C.AntiParam v _) = Just $ antiVarP v
  qqParamP _                 = Nothing
  
  qqParamListP :: [C.Param] -> Maybe (Q Pat)
  qqParamListP [] = Just $ listP []
  qqParamListP [C.AntiParams v _] = Just $ antiVarP v
  qqParamListP (C.AntiParams{} : _ : _) =
      error "Antiquoted list of parameters must be last item in quoted list"
  qqParamListP (arg : args) =
      Just $ conP (mkName ":") [dataToPatQ qqPat arg,  dataToPatQ qqPat args]
  
  qqDefinitionP :: C.Definition -> Maybe (Q Pat)
  qqDefinitionP (C.AntiFunc v _)  = Just $ conP (mkName "C.FuncDef") [antiVarP v, wildP]
  qqDefinitionP (C.AntiEsc v _)   = Just $ conP (mkName "C.EscDef") [antiVarP v, wildP]
  qqDefinitionP (C.AntiEdecl v _) = Just $ antiVarP v
  qqDefinitionP _                 = Nothing
  
  qqDefinitionListP :: [C.Definition] -> Maybe (Q Pat)
  qqDefinitionListP [] = Just $ listP []
  qqDefinitionListP [C.AntiEdecls v _] = Just $ antiVarP v
  qqDefinitionListP (C.AntiEdecls{} : _ : _) =
      error "Antiquoted list of definitions must be last item in quoted list"
  qqDefinitionListP (arg : args) =
      Just $ conP (mkName ":") [dataToPatQ qqPat arg,  dataToPatQ qqPat args]
  
  qqConstP :: C.Const -> Maybe (Q Pat)
  qqConstP = go
    where
      go (C.AntiInt v _) =
          Just $ con "C.IntConst" [wildP, signed, antiVarP v, wildP]
      go (C.AntiUInt v _) =
          Just $ con "C.IntConst" [wildP, unsigned, antiVarP v, wildP]
      go (C.AntiLInt v _) =
          Just $ con "C.LongIntConst" [wildP, signed, antiVarP v, wildP]
      go (C.AntiULInt v _) =
          Just $ con "C.LongIntConst" [wildP, unsigned, antiVarP v, wildP]
      go (C.AntiFloat v _) =
          Just $ con "C.FloatConst" [wildP, antiVarP v, wildP]
      go (C.AntiDouble v _) =
          Just $ con "C.DoubleConst" [wildP, antiVarP v, wildP]
      go (C.AntiLongDouble v _) =
          Just $ con "C.LongDoubleConst" [wildP, antiVarP v, wildP]
      go (C.AntiChar v _) =
          Just $ con "C.CharConst" [wildP, antiVarP v, wildP]
      go (C.AntiString v _) =
          Just $ con "C.StringConst" [wildP, antiVarP v, wildP]
      go _ =
          Nothing
  
      con n = conP (mkName n)
  
      signed   = conP (mkName "C.Signed") []
      unsigned = conP (mkName "C.Unsigned") []
  
  qqExpP :: C.Exp -> Maybe (Q Pat)
  qqExpP (C.AntiExp v _)    = Just $ antiVarP v
  qqExpP (C.AntiEscExp v _) = Just $ conP (mkName "C.EscExp") [antiVarP v, wildP]
  qqExpP _                  = Nothing
  
  qqExpListP :: [C.Exp] -> Maybe (Q Pat)
  qqExpListP [] = Just $ listP []
  qqExpListP [C.AntiArgs v _] = Just $ antiVarP v
  qqExpListP (C.AntiArgs{} : _ : _) =
      error "Antiquoted list of arguments must be last item in quoted list"
  qqExpListP (arg : args) =
      Just $ conP (mkName ":") [dataToPatQ qqPat arg,  dataToPatQ qqPat args]
  
  qqStmP :: C.Stm -> Maybe (Q Pat)
  qqStmP (C.AntiStm v _)    = Just $ antiVarP v
  qqStmP (C.AntiEscStm v _) = Just $ conP (mkName "C.EscStm") [antiVarP v, wildP]
  qqStmP _                  = Nothing
  
  qqStmListP :: [C.Stm] -> Maybe (Q Pat)
  qqStmListP [] = Just $ listP []
  qqStmListP [C.AntiStms v _] = Just $ antiVarP v
  qqStmListP (C.AntiStms{} : _ : _) =
      error "Antiquoted list of statements must be last item in quoted list"
  qqStmListP (arg : args) =
      Just $ conP (mkName ":") [dataToPatQ qqPat arg,  dataToPatQ qqPat args]
  
  qqBlockItemP :: C.BlockItem -> Maybe (Q Pat)
  qqBlockItemP (C.AntiBlockItem v _) = Just $ antiVarP v
  qqBlockItemP _                     = Nothing
  
  qqBlockItemListP :: [C.BlockItem] -> Maybe (Q Pat)
  qqBlockItemListP [] = Just $ listP []
  qqBlockItemListP (C.BlockDecl C.AntiDecls{} : _) =
      error "Antiquoted list of declarations cannot appear in block"
  qqBlockItemListP (C.BlockStm C.AntiStms{} : _) =
      error "Antiquoted list of statements cannot appear in block"
  qqBlockItemListP [C.AntiBlockItems v _] = Just $ antiVarP v
  qqBlockItemListP (C.AntiBlockItems{} : _ : _) =
      error "Antiquoted list of block items must be last item in quoted list"
  qqBlockItemListP (arg : args) =
      Just $ conP (mkName ":") [dataToPatQ qqPat arg,  dataToPatQ qqPat args]
  
  qqPat :: Typeable a => a -> Maybe (Q Pat)
  qqPat = const Nothing `extQ` qqStringP
                        `extQ` qqLocP
                        `extQ` qqIdP
                        `extQ` qqDeclSpecP
                        `extQ` qqDeclP
                        `extQ` qqTypeQualP
                        `extQ` qqTypeQualListP
                        `extQ` qqTypeP
                        `extQ` qqInitializerP
                        `extQ` qqInitializerListP
                        `extQ` qqInitGroupP
                        `extQ` qqInitGroupListP
                        `extQ` qqAttrP
                        `extQ` qqAttrListP
                        `extQ` qqFieldGroupP
                        `extQ` qqCEnumP
                        `extQ` qqCEnumListP
                        `extQ` qqParamP
                        `extQ` qqParamListP
                        `extQ` qqDefinitionP
                        `extQ` qqDefinitionListP
                        `extQ` qqConstP
                        `extQ` qqExpP
                        `extQ` qqExpListP
                        `extQ` qqStmP
                        `extQ` qqStmListP
                        `extQ` qqBlockItemP
                        `extQ` qqBlockItemListP
  
  parse :: [C.Extensions]
        -> [String]
        -> P.P a
        -> String
        -> Q a
  parse exts typenames p s = do
      loc <- location
      case P.parse (C.Antiquotation : exts) typenames p (B.pack s) (Just (locToPos loc)) of
        Left err -> fail (show err)
        Right x  -> return x
    where
      locToPos :: TH.Loc -> Pos
      locToPos TH.Loc {loc_filename = filename, loc_start = (line, col)} =
          Pos filename line col 0
  
  quasiquote :: Data a
             => [C.Extensions]
             -> [String]
             -> P.P a
             -> QuasiQuoter
  quasiquote exts typenames p =
      QuasiQuoter { quoteExp  = parse exts typenames p >=> dataToExpQ qqExp
                  , quotePat  = parse exts typenames p >=> dataToPatQ qqPat
                  , quoteType = error "C type quasiquoter undefined"
                  , quoteDec  = error "C declaration quasiquoter undefined"
                  }
  
  #if !MIN_VERSION_template_haskell(2,7,0)
  dataToQa  ::  forall a k q. Data a
            =>  (Name -> k)
            ->  (Lit -> Q q)
            ->  (k -> [Q q] -> Q q)
            ->  (forall b . Data b => b -> Maybe (Q q))
            ->  a
            ->  Q q
  dataToQa mkCon mkLit appCon antiQ t =
      case antiQ t of
        Nothing ->
            case constrRep constr of
              AlgConstr _  ->
                  appCon con conArgs
              IntConstr n ->
                  mkLit $ integerL n
              FloatConstr n ->
                  mkLit $ rationalL (toRational n)
              CharConstr c ->
                  mkLit $ charL c
          where
            constr :: Constr
            constr = toConstr t
  
            con :: k
            con = mkCon (mkConName mod occ)
              where
                mod :: String
                mod = (tyconModule . dataTypeName . dataTypeOf) t
  
                occ :: String
                occ = showConstr constr
  
                mkConName :: String -> String -> Name
                mkConName "Prelude" "(:)" = Name (mkOccName ":") NameS
                mkConName "Prelude" "[]"  = Name (mkOccName "[]") NameS
                mkConName "Prelude" "()"  = Name (mkOccName "()") NameS
  
                mkConName "Prelude" s@('(' : ',' : rest) = go rest
                  where
                    go :: String -> Name
                    go (',' : rest) = go rest
                    go ")"          = Name (mkOccName s) NameS
                    go _            = Name (mkOccName occ) (NameQ (mkModName mod))
  
                mkConName "GHC.Real" ":%" = mkNameG_d "base" "GHC.Real" ":%"
  
                mkConName mod occ = Name (mkOccName occ) (NameQ (mkModName mod))
  
            conArgs :: [Q q]
            conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t
  
        Just y -> y
  
  -- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the same
  -- value. It takes a function to handle type-specific cases.
  dataToExpQ  ::  Data a
              =>  (forall b . Data b => b -> Maybe (Q Exp))
              ->  a
              ->  Q Exp
  dataToExpQ = dataToQa conE litE (foldl appE)
  
  -- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same
  -- value. It takes a function to handle type-specific cases.
  dataToPatQ  ::  Data a
              =>  (forall b . Data b => b -> Maybe (Q Pat))
              ->  a
              ->  Q Pat
  dataToPatQ = dataToQa id litP conP
  #endif /* !MIN_VERSION_template_haskell(2,7,0) */
  