{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MonoLocalBinds #-}

module Language.C.Inline.Internal
    ( -- * Context handling
      setContext
    , getContext

      -- * Substitution
    , Substitutions(..)
    , substitute
    , getHaskellType

      -- * Emitting and invoking C code
      --
      -- | The functions in this section let us access more the C file
      -- associated with the current module.  They can be used to build
      -- additional features on top of the basic machinery.  All of
      -- @inline-c@ is based upon the functions defined here.

      -- ** Emitting C code
    , emitVerbatim
    , emitBlock

      -- ** Inlining C code
      -- $embedding
    , Code(..)
    , inlineCode
    , inlineExp
    , inlineItems

      -- * Parsing
      --
      -- | These functions are used to parse the anti-quotations.  They're
      -- exposed for testing purposes, you really should not use them.
    , SomeEq
    , toSomeEq
    , fromSomeEq
    , ParameterType(..)
    , ParseTypedC(..)
    , parseTypedC
    , runParserInQ
    , splitTypedC

      -- * Line directives
    , lineDirective
    , here
    , shiftLines

      -- * Utility functions for writing quasiquoters
    , genericQuote
    , funPtrQuote
    ) where

import           Control.Applicative
import           Control.Monad (forM, void, msum)
import           Control.Monad.State (evalStateT, StateT, get, put)
import           Control.Monad.Trans.Class (lift)
import           Data.Foldable (forM_)
import qualified Data.Map as Map
import           Data.Maybe (fromMaybe, isJust)
import           Data.Traversable (for)
import           Data.Typeable (Typeable, cast)
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Quote as TH
import qualified Language.Haskell.TH.Syntax as TH
import           System.Environment (lookupEnv)
import           System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO)
import qualified Text.Parsec as Parsec
import qualified Text.Parsec.Pos as Parsec
import qualified Text.Parser.Char as Parser
import qualified Text.Parser.Combinators as Parser
import qualified Text.Parser.LookAhead as Parser
import qualified Text.Parser.Token as Parser
import           Prettyprinter ((<+>))
import qualified Prettyprinter as PP
import qualified Prettyprinter.Render.String as PP
import qualified Data.List as L
import qualified Data.Char as C
import           Data.Hashable (Hashable)
import           Foreign.Ptr (FunPtr)
import qualified Data.Map as M

-- We cannot use getQ/putQ before 7.10.3 because of <https://ghc.haskell.org/trac/ghc/ticket/10596>
#define USE_GETQ (__GLASGOW_HASKELL__ > 710 || (__GLASGOW_HASKELL__ == 710 && __GLASGOW_HASKELL_PATCHLEVEL1__ >= 3))

#if !USE_GETQ
import           Control.Concurrent.MVar (MVar, newMVar, modifyMVar_, readMVar)
#endif

import           Language.C.Inline.Context
import           Language.C.Inline.FunPtr
import           Language.C.Inline.HaskellIdentifier
import qualified Language.C.Types as C

data ModuleState = ModuleState
  { ModuleState -> Context
msContext :: Context
  , ModuleState -> Int
msGeneratedNames :: Int
  , ModuleState -> [String]
msFileChunks :: [String]
  } deriving (Typeable)

getModuleState :: TH.Q (Maybe ModuleState)
putModuleState :: ModuleState -> TH.Q ()

#if USE_GETQ

getModuleState :: Q (Maybe ModuleState)
getModuleState = Q (Maybe ModuleState)
forall a. Typeable a => Q (Maybe a)
TH.getQ
putModuleState :: ModuleState -> Q ()
putModuleState = ModuleState -> Q ()
forall a. Typeable a => a -> Q ()
TH.putQ

#else

-- | Identifier for the current module.  Currently we use the file name.
-- Since we're pairing Haskell files with C files, it makes more sense
-- to use the file name.  I'm not sure if it's possible to compile two
-- modules with the same name in one run of GHC, but in this way we make
-- sure that we don't run into trouble even it is.
type ModuleId = String

getModuleId :: TH.Q ModuleId
getModuleId = TH.loc_filename <$> TH.location

-- | 'MVar' storing the state for all the modules we visited.  Note that
-- currently we do not bother with cleaning up the state after we're
-- done compiling a module.  TODO if there is an easy way, clean up the
-- state.
{-# NOINLINE moduleStatesVar #-}
moduleStatesVar :: MVar (Map.Map ModuleId ModuleState)
moduleStatesVar = unsafePerformIO $ newMVar Map.empty

getModuleState = do
  moduleStates <- TH.runIO (readMVar moduleStatesVar)
  moduleId <- getModuleId
  return (Map.lookup moduleId moduleStates)

putModuleState ms = do
  moduleId <- getModuleId
  TH.runIO (modifyMVar_ moduleStatesVar (return . Map.insert moduleId ms))

#endif


-- | Make sure that 'moduleStatesVar' and the respective C file are up
--   to date.
initialiseModuleState
  :: Maybe Context
  -- ^ The 'Context' to use if we initialise the module.  If 'Nothing',
  -- 'baseCtx' will be used.
  -> TH.Q Context
initialiseModuleState :: Maybe Context -> Q Context
initialiseModuleState Maybe Context
mbContext = do
  mbModuleState <- Q (Maybe ModuleState)
getModuleState
  case mbModuleState of
    Just ModuleState
moduleState -> Context -> Q Context
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleState -> Context
msContext ModuleState
moduleState)
    Maybe ModuleState
Nothing -> do
      -- Add hook to add the file
      Q () -> Q ()
TH.addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
        mbMs <- Q (Maybe ModuleState)
getModuleState
        ms <- case mbMs of
          Maybe ModuleState
Nothing -> String -> Q ModuleState
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"inline-c: ModuleState not present (initialiseModuleState)"
          Just ModuleState
ms -> ModuleState -> Q ModuleState
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleState
ms
        let lang = ForeignSrcLang -> Maybe ForeignSrcLang -> ForeignSrcLang
forall a. a -> Maybe a -> a
fromMaybe ForeignSrcLang
TH.LangC (Context -> Maybe ForeignSrcLang
ctxForeignSrcLang Context
context)
            addForeignSource =
#if MIN_VERSION_base(4,12,0)
              ForeignSrcLang -> String -> Q ()
TH.addForeignSource
#else
              TH.addForeignFile
#endif
            src = ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> [String]
forall a. [a] -> [a]
reverse (ModuleState -> [String]
msFileChunks ModuleState
ms)))
        case (lang, ctxRawObjectCompile context) of
          (ForeignSrcLang
TH.RawObject, Just String -> Q String
compile) -> String -> Q String
compile String
src Q String -> (String -> Q ()) -> Q ()
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ForeignSrcLang -> String -> Q ()
TH.addForeignFilePath ForeignSrcLang
lang
          (ForeignSrcLang
_, Maybe (String -> Q String)
_)  -> ForeignSrcLang -> String -> Q ()
addForeignSource ForeignSrcLang
lang String
src
      let moduleState :: ModuleState
moduleState = ModuleState
            { msContext :: Context
msContext = Context
context
            , msGeneratedNames :: Int
msGeneratedNames = Int
0
            , msFileChunks :: [String]
msFileChunks = [String]
forall a. Monoid a => a
mempty
            }
      ModuleState -> Q ()
putModuleState ModuleState
moduleState
      Context -> Q Context
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Context
context
  where
    context :: Context
context = Context -> Maybe Context -> Context
forall a. a -> Maybe a -> a
fromMaybe Context
baseCtx Maybe Context
mbContext

-- | Gets the current 'Context'.  Also makes sure that the current
-- module is initialised.
getContext :: TH.Q Context
getContext :: Q Context
getContext = Maybe Context -> Q Context
initialiseModuleState Maybe Context
forall a. Maybe a
Nothing

modifyModuleState :: (ModuleState -> (ModuleState, a)) -> TH.Q a
modifyModuleState :: forall a. (ModuleState -> (ModuleState, a)) -> Q a
modifyModuleState ModuleState -> (ModuleState, a)
f = do
  mbModuleState <- Q (Maybe ModuleState)
getModuleState
  case mbModuleState of
    Maybe ModuleState
Nothing -> String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"inline-c: ModuleState not present (modifyModuleState)"
    Just ModuleState
ms -> do
      let (ModuleState
ms', a
x) = ModuleState -> (ModuleState, a)
f ModuleState
ms
      ModuleState -> Q ()
putModuleState ModuleState
ms'
      a -> Q a
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- $context
--
-- The inline C functions ('cexp', 'c', etc.) need a 'Context' to
-- operate.  Said context can be explicitely set with 'setContext'.
-- Otherwise, at the first usage of one of the TH functions in this
-- module the 'Context' is implicitely set to 'baseCtx'.

-- | Sets the 'Context' for the current module.  This function, if
-- called, must be called before any of the other TH functions in this
-- module.  Fails if that's not the case.
setContext :: Context -> TH.Q ()
setContext :: Context -> Q ()
setContext Context
ctx = do
  mbModuleState <- Q (Maybe ModuleState)
getModuleState
  forM_ mbModuleState $ \ModuleState
_ms ->
    String -> Q (ZonkAny 6)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"inline-c: The module has already been initialised (setContext)."
  void $ initialiseModuleState $ Just ctx

bumpGeneratedNames :: TH.Q Int
bumpGeneratedNames :: Q Int
bumpGeneratedNames = do
  (ModuleState -> (ModuleState, Int)) -> Q Int
forall a. (ModuleState -> (ModuleState, a)) -> Q a
modifyModuleState ((ModuleState -> (ModuleState, Int)) -> Q Int)
-> (ModuleState -> (ModuleState, Int)) -> Q Int
forall a b. (a -> b) -> a -> b
$ \ModuleState
ms ->
    let c' :: Int
c' = ModuleState -> Int
msGeneratedNames ModuleState
ms
    in (ModuleState
ms{msGeneratedNames = c' + 1}, Int
c')

------------------------------------------------------------------------
-- Emitting

-- | Simply appends some string to the module's C file.  Use with care.
emitVerbatim :: String -> TH.DecsQ
emitVerbatim :: String -> DecsQ
emitVerbatim String
s = do
  -- Make sure that the 'ModuleState' is initialized
  Q Context -> Q ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Maybe Context -> Q Context
initialiseModuleState Maybe Context
forall a. Maybe a
Nothing)
  let chunk :: String
chunk = String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
  (ModuleState -> (ModuleState, ())) -> Q ()
forall a. (ModuleState -> (ModuleState, a)) -> Q a
modifyModuleState ((ModuleState -> (ModuleState, ())) -> Q ())
-> (ModuleState -> (ModuleState, ())) -> Q ()
forall a b. (a -> b) -> a -> b
$ \ModuleState
ms ->
    (ModuleState
ms{msFileChunks = chunk : msFileChunks ms}, ())
  [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Simply appends some string of block to the module's C file.  Use with care.
emitBlock :: TH.QuasiQuoter
emitBlock :: QuasiQuoter
emitBlock = TH.QuasiQuoter
  { quoteExp :: String -> Q Exp
TH.quoteExp = Q Exp -> String -> Q Exp
forall a b. a -> b -> a
const (Q Exp -> String -> Q Exp) -> Q Exp -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"inline-c: quoteExp not implemented (quoteCode)"
  , quotePat :: String -> Q Pat
TH.quotePat = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"inline-c: quotePat not implemented (quoteCode)"
  , quoteType :: String -> Q Type
TH.quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"inline-c: quoteType not implemented (quoteCode)"
  , quoteDec :: String -> DecsQ
TH.quoteDec = String -> DecsQ
emitVerbatim
  }

------------------------------------------------------------------------
-- Inlining

-- $embedding
--
-- We use the 'Code' data structure to represent some C code that we
-- want to emit to the module's C file and immediately generate a
-- foreign call to.  For this reason, 'Code' includes both some C
-- definition, and enough information to be able to generate a foreign
-- call -- specifically the name of the function to call and the Haskell
-- type.
--
-- All the quasi-quoters work by constructing a 'Code' and calling
-- 'inlineCode'.

-- | Data type representing a list of C definitions with a typed and named entry
-- function.
--
-- We use it as a basis to inline and call C code.
data Code = Code
  { Code -> Safety
codeCallSafety :: TH.Safety
    -- ^ Safety of the foreign call.
  , Code -> Maybe Loc
codeLoc :: Maybe TH.Loc
    -- ^ The haskell source location used for the #line directive
  , Code -> Q Type
codeType :: TH.TypeQ
    -- ^ Type of the foreign call.
  , Code -> String
codeFunName :: String
    -- ^ Name of the function to call in the code below.
  , Code -> String
codeDefs :: String
    -- ^ The C code.
  , Code -> Bool
codeFunPtr :: Bool
    -- ^ If 'True', the type will be wrapped in 'FunPtr', and
    -- the call will be static (e.g. prefixed by &).
  }

-- TODO use the #line CPP macro to have the functions in the C file
-- refer to the source location in the Haskell file they come from.
--
-- See <https://gcc.gnu.org/onlinedocs/cpp/Line-Control.html>.

-- | Inlines a piece of code inline.  The resulting 'TH.Exp' will have
-- the type specified in the 'codeType'.
--
-- In practice, this function outputs the C code to the module's C file,
-- and then inserts a foreign call of type 'codeType' calling the
-- provided 'codeFunName'.
--
-- Example:
--
-- @
-- c_add :: Int -> Int -> Int
-- c_add = $(do
--   here <- TH.location
--   inlineCode $ Code
--     TH.Unsafe                   -- Call safety
--     (Just here)
--     [t| Int -> Int -> Int |]    -- Call type
--     "francescos_add"            -- Call name
--     -- C Code
--     \"int francescos_add(int x, int y) { int z = x + y; return z; }\")
-- @
inlineCode :: Code -> TH.ExpQ
inlineCode :: Code -> Q Exp
inlineCode Code{Bool
String
Maybe Loc
Q Type
Safety
codeCallSafety :: Code -> Safety
codeLoc :: Code -> Maybe Loc
codeType :: Code -> Q Type
codeFunName :: Code -> String
codeDefs :: Code -> String
codeFunPtr :: Code -> Bool
codeCallSafety :: Safety
codeLoc :: Maybe Loc
codeType :: Q Type
codeFunName :: String
codeDefs :: String
codeFunPtr :: Bool
..} = do
  -- Write out definitions
  ctx <- Q Context
getContext
  let out = (String -> String) -> Maybe (String -> String) -> String -> String
forall a. a -> Maybe a -> a
fromMaybe String -> String
forall a. a -> a
id (Maybe (String -> String) -> String -> String)
-> Maybe (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Context -> Maybe (String -> String)
ctxOutput Context
ctx
  let directive = String -> (Loc -> String) -> Maybe Loc -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Loc -> String
lineDirective Maybe Loc
codeLoc
  void $ emitVerbatim $ out $ directive ++ codeDefs
  -- Create and add the FFI declaration.
  ffiImportName <- uniqueFfiImportName
  -- Note [ghcide-support]
  -- haskell-language-server / ghcide cannot handle code that use
  -- `addForeignFile`/`addForeignSource` as we do here; it will result
  -- in linker errors during TH evaluations, see:
  -- <https://github.com/haskell/haskell-language-server/issues/365#issuecomment-976294466>
  -- Thus for GHCIDE, simply generate a call to `error` instead of a call to a foreign import.
  usingGhcide <- TH.runIO $ isJust <$> lookupEnv "__GHCIDE__"
  if usingGhcide
    then do
      [e|error "inline-c: A 'usingGhcide' inlineCode stub was evaluated -- this should not happen" :: $(if codeFunPtr then [t| FunPtr $(codeType) |] else codeType) |]
    else do -- Actual foreign function call generation.
      dec <- if codeFunPtr
        then TH.forImpD TH.CCall codeCallSafety ("&" ++ codeFunName) ffiImportName [t| FunPtr $(codeType) |]
        else TH.forImpD TH.CCall codeCallSafety codeFunName ffiImportName codeType
      TH.addTopDecls [dec]
      TH.varE ffiImportName

uniqueCName :: Maybe String -> TH.Q String
uniqueCName :: Maybe String -> Q String
uniqueCName Maybe String
mbPostfix = do
  -- The name looks like this:
  -- inline_c_MODULE_INDEX_POSTFIX
  --
  -- Where:
  --  * MODULE is the module name but with _s instead of .s;
  --  * INDEX is a counter that keeps track of how many names we're generating
  --    for each module.
  --  * POSTFIX is an optional postfix to ease debuggability
  --
  -- we previously also generated a hash from the contents of the
  -- C code because of problems when cabal recompiled but now this
  -- is not needed anymore since we use 'addDependentFile' to compile
  -- the C code.
  c' <- Q Int
bumpGeneratedNames
  module_ <- TH.loc_module <$> TH.location
  let replaceDot Char
'.' = Char
'_'
      replaceDot Char
c = Char
c
  let postfix = case Maybe String
mbPostfix of
        Maybe String
Nothing -> String
""
        Just String
s -> String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"
  return $ "inline_c_" ++ map replaceDot module_ ++ "_" ++ show c' ++ postfix

-- | Same as 'inlineCItems', but with a single expression.
--
-- @
-- c_cos :: Double -> Double
-- c_cos = $(do
--   here <- TH.location
--   inlineExp
--     TH.Unsafe
--     here
--     [t| Double -> Double |]
--     (quickCParser_ \"double\" parseType)
--     [("x", quickCParser_ \"double\" parseType)]
--     "cos(x)")
-- @
inlineExp
  :: TH.Safety
  -- ^ Safety of the foreign call
  -> TH.Loc
  -- ^ The location to report
  -> TH.TypeQ
  -- ^ Type of the foreign call
  -> C.Type C.CIdentifier
  -- ^ Return type of the C expr
  -> [(C.CIdentifier, C.Type C.CIdentifier)]
  -- ^ Parameters of the C expr
  -> String
  -- ^ The C expression
  -> TH.ExpQ
inlineExp :: Safety
-> Loc
-> Q Type
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> String
-> Q Exp
inlineExp Safety
callSafety Loc
loc Q Type
type_ Type CIdentifier
cRetType [(CIdentifier, Type CIdentifier)]
cParams String
cExp =
  Safety
-> Bool
-> Maybe String
-> Loc
-> Q Type
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> String
-> Q Exp
inlineItems Safety
callSafety Bool
False Maybe String
forall a. Maybe a
Nothing Loc
loc Q Type
type_ Type CIdentifier
cRetType [(CIdentifier, Type CIdentifier)]
cParams String
cItems
  where
    cItems :: String
cItems = case Type CIdentifier
cRetType of
      C.TypeSpecifier Specifiers
_quals TypeSpecifier
C.Void -> String
cExp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
      Type CIdentifier
_ -> String
"return (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cExp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");"

-- | Same as 'inlineCode', but accepts a string containing a list of C
-- statements instead instead than a full-blown 'Code'.  A function
-- containing the provided statement will be automatically generated.
--
-- @
-- c_cos :: Double -> Double
-- c_cos = $(do
--  here <- TH.location
--  inlineItems
--   TH.Unsafe
--   False
--   Nothing
--   here
--   [t| Double -> Double |]
--   (quickCParser_ \"double\" parseType)
--   [("x", quickCParser_ \"double\" parseType)]
--   "return cos(x);")
-- @
inlineItems
  :: TH.Safety
  -- ^ Safety of the foreign call
  -> Bool
  -- ^ Whether to return as a FunPtr or not
  -> Maybe String
  -- ^ Optional postfix for the generated name
  -> TH.Loc
  -- ^ The location to report
  -> TH.TypeQ
  -- ^ Type of the foreign call
  -> C.Type C.CIdentifier
  -- ^ Return type of the C expr
  -> [(C.CIdentifier, C.Type C.CIdentifier)]
  -- ^ Parameters of the C expr
  -> String
  -- ^ The C items
  -> TH.ExpQ
inlineItems :: Safety
-> Bool
-> Maybe String
-> Loc
-> Q Type
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> String
-> Q Exp
inlineItems Safety
callSafety Bool
funPtr Maybe String
mbPostfix Loc
loc Q Type
type_ Type CIdentifier
cRetType [(CIdentifier, Type CIdentifier)]
cParams String
cItems = do
  let mkParam :: (i, Type i) -> ParameterDeclaration i
mkParam (i
id', Type i
paramTy) = Maybe i -> Type i -> ParameterDeclaration i
forall i. Maybe i -> Type i -> ParameterDeclaration i
C.ParameterDeclaration (i -> Maybe i
forall a. a -> Maybe a
Just i
id') Type i
paramTy
  let proto :: Type CIdentifier
proto = Type CIdentifier
-> [ParameterDeclaration CIdentifier] -> Type CIdentifier
forall i. Type i -> [ParameterDeclaration i] -> Type i
C.Proto Type CIdentifier
cRetType (((CIdentifier, Type CIdentifier)
 -> ParameterDeclaration CIdentifier)
-> [(CIdentifier, Type CIdentifier)]
-> [ParameterDeclaration CIdentifier]
forall a b. (a -> b) -> [a] -> [b]
map (CIdentifier, Type CIdentifier) -> ParameterDeclaration CIdentifier
forall {i}. (i, Type i) -> ParameterDeclaration i
mkParam [(CIdentifier, Type CIdentifier)]
cParams)
  ctx <- Q Context
getContext
  funName <- uniqueCName mbPostfix
  cFunName <- case C.cIdentifierFromString (ctxEnableCpp ctx) funName of
    Left String
err -> String -> Q CIdentifier
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q CIdentifier) -> String -> Q CIdentifier
forall a b. (a -> b) -> a -> b
$ String
"inlineItems: impossible, generated bad C identifier " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                       String
"funName:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
    Right CIdentifier
x -> CIdentifier -> Q CIdentifier
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return CIdentifier
x
  let decl = Maybe CIdentifier
-> Type CIdentifier -> ParameterDeclaration CIdentifier
forall i. Maybe i -> Type i -> ParameterDeclaration i
C.ParameterDeclaration (CIdentifier -> Maybe CIdentifier
forall a. a -> Maybe a
Just CIdentifier
cFunName) Type CIdentifier
proto
  let defs = Doc (ZonkAny 4) -> String
forall ann. Doc ann -> String
prettyOneLine (ParameterDeclaration CIdentifier -> Doc (ZonkAny 4)
forall a ann. Pretty a => a -> Doc ann
forall ann. ParameterDeclaration CIdentifier -> Doc ann
PP.pretty ParameterDeclaration CIdentifier
decl) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cItems String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }\n"
  inlineCode $ Code
    { codeCallSafety = callSafety
    , codeLoc = Just loc
    , codeType = type_
    , codeFunName = funName
    , codeDefs = defs
    , codeFunPtr = funPtr
    }

------------------------------------------------------------------------
-- Parsing

runParserInQ
  :: (Hashable ident)
  => String
  -> C.CParserContext ident
  -> (forall m. C.CParser ident m => m a) -> TH.Q a
runParserInQ :: forall ident a.
Hashable ident =>
String
-> CParserContext ident
-> (forall (m :: * -> *). CParser ident m => m a)
-> Q a
runParserInQ String
s CParserContext ident
ctx forall (m :: * -> *). CParser ident m => m a
p = do
  loc <- Q Loc
TH.location
  let (line, col) = TH.loc_start loc
  let parsecLoc = String -> Int -> Int -> SourcePos
Parsec.newPos (Loc -> String
TH.loc_filename Loc
loc) Int
line Int
col
  let p' = ParsecT String () Identity ()
-> ReaderT (CParserContext ident) (ParsecT String () Identity) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (CParserContext ident) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SourcePos -> ParsecT String () Identity ()
forall (m :: * -> *) s u. Monad m => SourcePos -> ParsecT s u m ()
Parsec.setPosition SourcePos
parsecLoc) ReaderT (CParserContext ident) (ParsecT String () Identity) ()
-> ReaderT (CParserContext ident) (ParsecT String () Identity) a
-> ReaderT (CParserContext ident) (ParsecT String () Identity) a
forall a b.
ReaderT (CParserContext ident) (ParsecT String () Identity) a
-> ReaderT (CParserContext ident) (ParsecT String () Identity) b
-> ReaderT (CParserContext ident) (ParsecT String () Identity) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReaderT (CParserContext ident) (ParsecT String () Identity) a
forall (m :: * -> *). CParser ident m => m a
p ReaderT (CParserContext ident) (ParsecT String () Identity) a
-> ReaderT (CParserContext ident) (ParsecT String () Identity) ()
-> ReaderT (CParserContext ident) (ParsecT String () Identity) a
forall a b.
ReaderT (CParserContext ident) (ParsecT String () Identity) a
-> ReaderT (CParserContext ident) (ParsecT String () Identity) b
-> ReaderT (CParserContext ident) (ParsecT String () Identity) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
-> ReaderT (CParserContext ident) (ParsecT String () Identity) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (CParserContext ident) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT String () Identity ()
forall (m :: * -> *). Parsing m => m ()
Parser.eof
  case C.runCParser ctx (TH.loc_filename loc) s p' of
    Left ParseError
err -> do
      -- TODO consider prefixing with "error while parsing C" or similar
      String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
    Right a
res -> do
      a -> Q a
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

data SomeEq = forall a. (Typeable a, Eq a) => SomeEq a

instance Eq SomeEq where
  SomeEq a
x == :: SomeEq -> SomeEq -> Bool
== SomeEq a
y = case a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x of
    Maybe a
Nothing -> Bool
False
    Just a
x' -> a
x' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y

instance Show SomeEq where
  show :: SomeEq -> String
show SomeEq
_ = String
"<<SomeEq>>"

toSomeEq :: (Eq a, Typeable a) => a -> SomeEq
toSomeEq :: forall a. (Eq a, Typeable a) => a -> SomeEq
toSomeEq a
x = a -> SomeEq
forall a. (Typeable a, Eq a) => a -> SomeEq
SomeEq a
x

fromSomeEq :: (Eq a, Typeable a) => SomeEq -> Maybe a
fromSomeEq :: forall a. (Eq a, Typeable a) => SomeEq -> Maybe a
fromSomeEq (SomeEq a
x) = a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x

data ParameterType
  = Plain HaskellIdentifier                -- The name of the captured variable
  | AntiQuote AntiQuoterId SomeEq
  deriving (Int -> ParameterType -> String -> String
[ParameterType] -> String -> String
ParameterType -> String
(Int -> ParameterType -> String -> String)
-> (ParameterType -> String)
-> ([ParameterType] -> String -> String)
-> Show ParameterType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ParameterType -> String -> String
showsPrec :: Int -> ParameterType -> String -> String
$cshow :: ParameterType -> String
show :: ParameterType -> String
$cshowList :: [ParameterType] -> String -> String
showList :: [ParameterType] -> String -> String
Show, ParameterType -> ParameterType -> Bool
(ParameterType -> ParameterType -> Bool)
-> (ParameterType -> ParameterType -> Bool) -> Eq ParameterType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParameterType -> ParameterType -> Bool
== :: ParameterType -> ParameterType -> Bool
$c/= :: ParameterType -> ParameterType -> Bool
/= :: ParameterType -> ParameterType -> Bool
Eq)

data ParseTypedC = ParseTypedC
  { ParseTypedC -> Type CIdentifier
ptcReturnType :: C.Type C.CIdentifier
  , ParseTypedC -> [(CIdentifier, Type CIdentifier, ParameterType)]
ptcParameters :: [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)]
  , ParseTypedC -> String
ptcBody :: String
  }

newtype Substitutions = Substitutions { Substitutions -> Map String (String -> String)
unSubstitutions :: M.Map String (String -> String) }

applySubstitutions :: String -> TH.Q String
applySubstitutions :: String -> Q String
applySubstitutions String
str = do
  subs <- Map String (String -> String)
-> (Substitutions -> Map String (String -> String))
-> Maybe Substitutions
-> Map String (String -> String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map String (String -> String)
forall a. Monoid a => a
mempty Substitutions -> Map String (String -> String)
unSubstitutions (Maybe Substitutions -> Map String (String -> String))
-> Q (Maybe Substitutions) -> Q (Map String (String -> String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (Maybe Substitutions)
forall a. Typeable a => Q (Maybe a)
TH.getQ
  let substitution = [ParsecT String () Identity String]
-> ParsecT String () Identity String
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([ParsecT String () Identity String]
 -> ParsecT String () Identity String)
-> [ParsecT String () Identity String]
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ (((String, String -> String) -> ParsecT String () Identity String)
 -> [(String, String -> String)]
 -> [ParsecT String () Identity String])
-> [(String, String -> String)]
-> ((String, String -> String)
    -> ParsecT String () Identity String)
-> [ParsecT String () Identity String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((String, String -> String) -> ParsecT String () Identity String)
-> [(String, String -> String)]
-> [ParsecT String () Identity String]
forall a b. (a -> b) -> [a] -> [b]
map (Map String (String -> String) -> [(String, String -> String)]
forall k a. Map k a -> [(k, a)]
M.toList Map String (String -> String)
subs) (((String, String -> String) -> ParsecT String () Identity String)
 -> [ParsecT String () Identity String])
-> ((String, String -> String)
    -> ParsecT String () Identity String)
-> [ParsecT String () Identity String]
forall a b. (a -> b) -> a -> b
$ \( String
subName, String -> String
subFunc ) ->
        ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
Parsec.try (ParsecT String () Identity String
 -> ParsecT String () Identity String)
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ do
          _ <- String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
Parsec.string (Char
'@' Char -> String -> String
forall a. a -> [a] -> [a]
: String
subName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(")
          subArg <- Parsec.manyTill Parsec.anyChar (Parsec.char ')')
          return (subFunc subArg)
  let someChar = (Char -> String -> String
forall a. a -> [a] -> [a]
:[]) (Char -> String)
-> ParsecT String u Identity Char
-> ParsecT String u Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
Parsec.anyChar
  case Parsec.parse (many (substitution <|> someChar)) "" str of
    Left ParseError
_ -> String -> Q String
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Substitution failed (should be impossible)"
    Right [String]
chunks -> String -> Q String
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
chunks)

-- | Define macros that can be used in the nested Template Haskell expression.
-- Macros can be used as @\@MACRO_NAME(input)@ in inline-c quotes, and will transform their input with the given function.
-- They can be useful for passing in types when defining Haskell instances for C++ template types.
substitute :: [ ( String, String -> String ) ] -> TH.Q a -> TH.Q a
substitute :: forall a. [(String, String -> String)] -> Q a -> Q a
substitute [(String, String -> String)]
subsList Q a
cont = do
  oldSubs <- Map String (String -> String)
-> (Substitutions -> Map String (String -> String))
-> Maybe Substitutions
-> Map String (String -> String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map String (String -> String)
forall a. Monoid a => a
mempty Substitutions -> Map String (String -> String)
unSubstitutions (Maybe Substitutions -> Map String (String -> String))
-> Q (Maybe Substitutions) -> Q (Map String (String -> String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (Maybe Substitutions)
forall a. Typeable a => Q (Maybe a)
TH.getQ
  let subs = [(String, String -> String)] -> Map String (String -> String)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String, String -> String)]
subsList
  let conflicting = Map String (String -> String)
-> Map String (String -> String) -> Map String (String -> String)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.intersection Map String (String -> String)
subs Map String (String -> String)
oldSubs
  newSubs <-
    if M.null conflicting
      then return (Substitutions (M.union oldSubs subs))
      else fail ("Conflicting substitutions `" ++ show (M.keys conflicting) ++ "`")
  TH.putQ newSubs *> cont <* TH.putQ (Substitutions oldSubs)

-- | Given a C type name, return the Haskell type in Template Haskell. The first parameter controls whether function pointers
-- should be mapped as pure or IO functions.
getHaskellType :: Bool -> String -> TH.TypeQ
getHaskellType :: Bool -> String -> Q Type
getHaskellType Bool
pureFunctions String
cTypeStr = do
  ctx <- Q Context
getContext
  let cParseCtx = Bool -> TypeNames -> CParserContext CIdentifier
C.cCParserContext (Context -> Bool
ctxEnableCpp Context
ctx) (TypesTable -> TypeNames
typeNamesFromTypesTable (Context -> TypesTable
ctxTypesTable Context
ctx))
  cType <- runParserInQ cTypeStr cParseCtx C.parseType
  cToHs ctx (if pureFunctions then Pure else IO) cType

-- To parse C declarations, we're faced with a bit of a problem: we want
-- to parse the anti-quotations so that Haskell identifiers are
-- accepted, but we want them to appear only as the root of
-- declarations.  For this reason, we parse allowing Haskell identifiers
-- everywhere, and then we "purge" Haskell identifiers everywhere but at
-- the root.
parseTypedC
  :: forall m. C.CParser HaskellIdentifier m
  => Bool -> AntiQuoters -> m ParseTypedC
  -- ^ Returns the return type, the captured variables, and the body.
parseTypedC :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
Bool -> AntiQuoters -> m ParseTypedC
parseTypedC Bool
useCpp AntiQuoters
antiQs = do
  -- Parse return type (consume spaces first)
  m ()
forall (m :: * -> *). CharParsing m => m ()
Parser.spaces
  cRetType <- Type HaskellIdentifier -> m (Type CIdentifier)
forall (n :: * -> *).
MonadFail n =>
Type HaskellIdentifier -> n (Type CIdentifier)
purgeHaskellIdentifiers (Type HaskellIdentifier -> m (Type CIdentifier))
-> m (Type HaskellIdentifier) -> m (Type CIdentifier)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Type HaskellIdentifier)
forall i (m :: * -> *). (CParser i m, Pretty i) => m (Type i)
C.parseType
  -- Parse the body
  void $ Parser.char '{'
  (cParams, cBody) <- evalStateT parseBody 0
  return $ ParseTypedC cRetType cParams cBody
  where
    parseBody
      :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)
    parseBody :: StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], String)
parseBody = do
      -- Note that this code does not use "lexing" combinators (apart
      -- when appropriate) because we want to make sure to preserve
      -- whitespace after we substitute things.
      s <- StateT Int m Char -> StateT Int m Char -> StateT Int m String
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m [a]
Parser.manyTill StateT Int m Char
forall (m :: * -> *). CharParsing m => m Char
Parser.anyChar (StateT Int m Char -> StateT Int m String)
-> StateT Int m Char -> StateT Int m String
forall a b. (a -> b) -> a -> b
$
           StateT Int m Char -> StateT Int m Char
forall a. StateT Int m a -> StateT Int m a
forall (m :: * -> *) a. LookAheadParsing m => m a -> m a
Parser.lookAhead (Char -> StateT Int m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'}' StateT Int m Char -> StateT Int m Char -> StateT Int m Char
forall a. StateT Int m a -> StateT Int m a -> StateT Int m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> StateT Int m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'$')
      (decls, s') <- msum
        [ do Parser.try $ do -- Try because we might fail to parse the 'eof'
                -- 'symbolic' because we want to consume whitespace
               void $ Parser.symbolic '}'
               Parser.eof
             return ([], "")
        , do void $ Parser.char '}'
             (decls, s') <- parseBody
             return (decls, "}" ++ s')
        , do void $ Parser.char '$'
             (decls1, s1) <- parseEscapedDollar <|> parseAntiQuote <|> parseTypedCapture
             (decls2, s2) <- parseBody
             return (decls1 ++ decls2, s1 ++ s2)
        ]
      return (decls, s ++ s')
      where

    parseAntiQuote
      :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)
    parseAntiQuote :: StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], String)
parseAntiQuote = [StateT
   Int m ([(CIdentifier, Type CIdentifier, ParameterType)], String)]
-> StateT
     Int m ([(CIdentifier, Type CIdentifier, ParameterType)], String)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
      [ do StateT Int m String -> StateT Int m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Int m String -> StateT Int m ())
-> StateT Int m String -> StateT Int m ()
forall a b. (a -> b) -> a -> b
$ StateT Int m String -> StateT Int m String
forall a. StateT Int m a -> StateT Int m a
forall (m :: * -> *) a. Parsing m => m a -> m a
Parser.try (String -> StateT Int m String
forall (m :: * -> *). CharParsing m => String -> m String
Parser.string (String -> StateT Int m String) -> String -> StateT Int m String
forall a b. (a -> b) -> a -> b
$ String
antiQId String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":") StateT Int m String -> String -> StateT Int m String
forall a. StateT Int m a -> String -> StateT Int m a
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
Parser.<?> String
"anti quoter id"
           (s, cTy, x) <- AntiQuoter a
-> forall (m :: * -> *).
   CParser HaskellIdentifier m =>
   m (CIdentifier, Type CIdentifier, a)
forall a.
AntiQuoter a
-> forall (m :: * -> *).
   CParser HaskellIdentifier m =>
   m (CIdentifier, Type CIdentifier, a)
aqParser AntiQuoter a
antiQ
           id' <- freshId s
           return ([(id', cTy, AntiQuote antiQId (toSomeEq x))], C.unCIdentifier id')
      | (String
antiQId, SomeAntiQuoter AntiQuoter a
antiQ) <- AntiQuoters -> [(String, SomeAntiQuoter)]
forall k a. Map k a -> [(k, a)]
Map.toList AntiQuoters
antiQs
      ]

    parseEscapedDollar :: StateT Int m ([a], String)
    parseEscapedDollar :: forall a. StateT Int m ([a], String)
parseEscapedDollar = do
      StateT Int m Char -> StateT Int m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Int m Char -> StateT Int m ())
-> StateT Int m Char -> StateT Int m ()
forall a b. (a -> b) -> a -> b
$ Char -> StateT Int m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'$'
      ([a], String) -> StateT Int m ([a], String)
forall a. a -> StateT Int m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], String
"$")

    parseTypedCapture
      :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)
    parseTypedCapture :: StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], String)
parseTypedCapture = do
      StateT Int m Char -> StateT Int m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Int m Char -> StateT Int m ())
-> StateT Int m Char -> StateT Int m ()
forall a b. (a -> b) -> a -> b
$ Char -> StateT Int m Char
forall (m :: * -> *). TokenParsing m => Char -> m Char
Parser.symbolic Char
'('
      decl <- StateT Int m (ParameterDeclaration HaskellIdentifier)
forall i (m :: * -> *).
(CParser i m, Pretty i) =>
m (ParameterDeclaration i)
C.parseParameterDeclaration
      declType <- purgeHaskellIdentifiers $ C.parameterDeclarationType decl
      -- Purge the declaration type of all the Haskell identifiers.
      hId <- case C.parameterDeclarationId decl of
        Maybe HaskellIdentifier
Nothing -> String -> StateT Int m HaskellIdentifier
forall a. String -> StateT Int m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT Int m HaskellIdentifier)
-> String -> StateT Int m HaskellIdentifier
forall a b. (a -> b) -> a -> b
$ Doc (ZonkAny 2) -> String
forall ann. Doc ann -> String
pretty80 (Doc (ZonkAny 2) -> String) -> Doc (ZonkAny 2) -> String
forall a b. (a -> b) -> a -> b
$
          Doc (ZonkAny 2)
"Un-named captured variable in decl" Doc (ZonkAny 2) -> Doc (ZonkAny 2) -> Doc (ZonkAny 2)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ParameterDeclaration HaskellIdentifier -> Doc (ZonkAny 2)
forall a ann. Pretty a => a -> Doc ann
forall ann. ParameterDeclaration HaskellIdentifier -> Doc ann
PP.pretty ParameterDeclaration HaskellIdentifier
decl
        Just HaskellIdentifier
hId -> HaskellIdentifier -> StateT Int m HaskellIdentifier
forall a. a -> StateT Int m a
forall (m :: * -> *) a. Monad m => a -> m a
return HaskellIdentifier
hId
      id' <- freshId $ mangleHaskellIdentifier useCpp hId
      void $ Parser.char ')'
      return ([(id', declType, Plain hId)], C.unCIdentifier id')

    freshId :: CIdentifier -> StateT Int m CIdentifier
freshId CIdentifier
s = do
      c <- StateT Int m Int
forall s (m :: * -> *). MonadState s m => m s
get
      put $ c + 1
      case C.cIdentifierFromString useCpp (C.unCIdentifier s ++ "_inline_c_" ++ show c) of
        Left String
_err -> String -> StateT Int m CIdentifier
forall a. HasCallStack => String -> a
error String
"freshId: The impossible happened"
        Right CIdentifier
x -> CIdentifier -> StateT Int m CIdentifier
forall a. a -> StateT Int m a
forall (m :: * -> *) a. Monad m => a -> m a
return CIdentifier
x

    -- The @m@ is polymorphic because we use this both for the plain
    -- parser and the StateT parser we use above.  We only need 'fail'.
    purgeHaskellIdentifiers
#if MIN_VERSION_base(4,13,0)
      :: forall n. MonadFail n
#else
      :: forall n. (Applicative n, Monad n)
#endif
      => C.Type HaskellIdentifier -> n (C.Type C.CIdentifier)
    purgeHaskellIdentifiers :: forall (n :: * -> *).
MonadFail n =>
Type HaskellIdentifier -> n (Type CIdentifier)
purgeHaskellIdentifiers Type HaskellIdentifier
cTy = Type HaskellIdentifier
-> (HaskellIdentifier -> n CIdentifier) -> n (Type CIdentifier)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Type HaskellIdentifier
cTy ((HaskellIdentifier -> n CIdentifier) -> n (Type CIdentifier))
-> (HaskellIdentifier -> n CIdentifier) -> n (Type CIdentifier)
forall a b. (a -> b) -> a -> b
$ \HaskellIdentifier
hsIdent -> do
      let hsIdentS :: String
hsIdentS = HaskellIdentifier -> String
unHaskellIdentifier HaskellIdentifier
hsIdent
      case Bool -> String -> Either String CIdentifier
C.cIdentifierFromString Bool
useCpp String
hsIdentS of
        Left String
err -> String -> n CIdentifier
forall a. String -> n a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> n CIdentifier) -> String -> n CIdentifier
forall a b. (a -> b) -> a -> b
$ String
"Haskell identifier " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hsIdentS String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in illegal position" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                           String
"in C type\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc (ZonkAny 3) -> String
forall ann. Doc ann -> String
pretty80 (Type HaskellIdentifier -> Doc (ZonkAny 3)
forall a ann. Pretty a => a -> Doc ann
forall ann. Type HaskellIdentifier -> Doc ann
PP.pretty Type HaskellIdentifier
cTy) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                           String
"A C identifier was expected, but:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
        Right CIdentifier
cIdent -> CIdentifier -> n CIdentifier
forall a. a -> n a
forall (m :: * -> *) a. Monad m => a -> m a
return CIdentifier
cIdent

quoteCode
  :: (String -> TH.ExpQ)
  -- ^ The parser
  -> TH.QuasiQuoter
quoteCode :: (String -> Q Exp) -> QuasiQuoter
quoteCode String -> Q Exp
p = TH.QuasiQuoter
  { quoteExp :: String -> Q Exp
TH.quoteExp = String -> Q Exp
p
  , quotePat :: String -> Q Pat
TH.quotePat = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"inline-c: quotePat not implemented (quoteCode)"
  , quoteType :: String -> Q Type
TH.quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"inline-c: quoteType not implemented (quoteCode)"
  , quoteDec :: String -> DecsQ
TH.quoteDec = DecsQ -> String -> DecsQ
forall a b. a -> b -> a
const (DecsQ -> String -> DecsQ) -> DecsQ -> String -> DecsQ
forall a b. (a -> b) -> a -> b
$ String -> DecsQ
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"inline-c: quoteDec not implemented (quoteCode)"
  }

cToHs :: Context -> Purity -> C.Type C.CIdentifier -> TH.TypeQ
cToHs :: Context -> Purity -> Type CIdentifier -> Q Type
cToHs Context
ctx Purity
purity Type CIdentifier
cTy = do
  mbHsTy <- Purity -> TypesTable -> Type CIdentifier -> Q (Maybe Type)
convertType Purity
purity (Context -> TypesTable
ctxTypesTable Context
ctx) Type CIdentifier
cTy
  case mbHsTy of
    Maybe Type
Nothing -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"Could not resolve Haskell type for C type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc (ZonkAny 1) -> String
forall ann. Doc ann -> String
pretty80 (Type CIdentifier -> Doc (ZonkAny 1)
forall a ann. Pretty a => a -> Doc ann
forall ann. Type CIdentifier -> Doc ann
PP.pretty Type CIdentifier
cTy)
    Just Type
hsTy -> Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
hsTy

genericQuote
  :: Purity
  -> (TH.Loc -> TH.TypeQ -> C.Type C.CIdentifier -> [(C.CIdentifier, C.Type C.CIdentifier)] -> String -> TH.ExpQ)
  -- ^ Function building an Haskell expression, see 'inlineExp' for
  -- guidance on the other args.
  -> TH.QuasiQuoter
genericQuote :: Purity
-> (Loc
    -> Q Type
    -> Type CIdentifier
    -> [(CIdentifier, Type CIdentifier)]
    -> String
    -> Q Exp)
-> QuasiQuoter
genericQuote Purity
purity Loc
-> Q Type
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> String
-> Q Exp
build = (String -> Q Exp) -> QuasiQuoter
quoteCode ((String -> Q Exp) -> QuasiQuoter)
-> (String -> Q Exp) -> QuasiQuoter
forall a b. (a -> b) -> a -> b
$ \String
rawStr -> do
    ctx <- Q Context
getContext
    here <- TH.location
    s <- applySubstitutions rawStr
    ParseTypedC cType cParams cExp <-
      runParserInQ s
        (haskellCParserContext (ctxEnableCpp ctx) (typeNamesFromTypesTable (ctxTypesTable ctx)))
        (parseTypedC (ctxEnableCpp ctx) (ctxAntiQuoters ctx))
    hsType <- cToHs ctx purity cType
    hsParams <- forM cParams $ \(CIdentifier
_cId, Type CIdentifier
cTy, ParameterType
parTy) -> do
      case ParameterType
parTy of
        Plain HaskellIdentifier
s' -> do
          hsTy <- Context -> Purity -> Type CIdentifier -> Q Type
cToHs Context
ctx Purity
purity Type CIdentifier
cTy
          let hsName = String -> Name
TH.mkName (HaskellIdentifier -> String
unHaskellIdentifier HaskellIdentifier
s')
          hsExp <- [| \cont -> cont ($(TH.varE hsName) :: $(return hsTy)) |]
          return (hsTy, hsExp)
        AntiQuote String
antiId SomeEq
dyn -> do
          case String -> AntiQuoters -> Maybe SomeAntiQuoter
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
antiId (Context -> AntiQuoters
ctxAntiQuoters Context
ctx) of
            Maybe SomeAntiQuoter
Nothing ->
              String -> Q (Type, Exp)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Exp)) -> String -> Q (Type, Exp)
forall a b. (a -> b) -> a -> b
$ String
"IMPOSSIBLE: could not find anti-quoter " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
antiId String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     String
". (genericQuote)"
            Just (SomeAntiQuoter AntiQuoter a
antiQ) -> case SomeEq -> Maybe a
forall a. (Eq a, Typeable a) => SomeEq -> Maybe a
fromSomeEq SomeEq
dyn of
              Maybe a
Nothing ->
                String -> Q (Type, Exp)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail  (String -> Q (Type, Exp)) -> String -> Q (Type, Exp)
forall a b. (a -> b) -> a -> b
$ String
"IMPOSSIBLE: could not cast value for anti-quoter " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        String -> String
forall a. Show a => a -> String
show String
antiId String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". (genericQuote)"
              Just a
x ->
                AntiQuoter a
-> Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp)
forall a.
AntiQuoter a
-> Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp)
aqMarshaller AntiQuoter a
antiQ Purity
purity (Context -> TypesTable
ctxTypesTable Context
ctx) Type CIdentifier
cTy a
x
    let hsFunType = Type -> [Type] -> Q Type
convertCFunSig Type
hsType ([Type] -> Q Type) -> [Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ ((Type, Exp) -> Type) -> [(Type, Exp)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Exp) -> Type
forall a b. (a, b) -> a
fst [(Type, Exp)]
hsParams
    let cParams' = [(CIdentifier
cId, Type CIdentifier
cTy) | (CIdentifier
cId, Type CIdentifier
cTy, ParameterType
_) <- [(CIdentifier, Type CIdentifier, ParameterType)]
cParams]
    ioCall <- buildFunCall ctx (build here hsFunType cType cParams' cExp) (map snd hsParams) []
    -- If the user requested a pure function, make it so.
    case purity of
      -- Using unsafeDupablePerformIO to increase performance of pure calls, see <https://github.com/fpco/inline-c/issues/115>
      Purity
Pure -> [| unsafeDupablePerformIO $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
ioCall) |]
      Purity
IO -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
ioCall
  where
    buildFunCall :: Context -> TH.ExpQ -> [TH.Exp] -> [TH.Name] -> TH.ExpQ
    buildFunCall :: Context -> Q Exp -> [Exp] -> [Name] -> Q Exp
buildFunCall Context
_ctx Q Exp
f [] [Name]
args =
      (Q Exp -> Name -> Q Exp) -> Q Exp -> [Name] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
f' Name
arg -> [| $Q Exp
f' $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
arg) |]) Q Exp
f [Name]
args
    buildFunCall Context
ctx Q Exp
f (Exp
hsExp : [Exp]
params) [Name]
args =
       [| $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
hsExp) $ \arg ->
            $(Context -> Q Exp -> [Exp] -> [Name] -> Q Exp
buildFunCall Context
ctx Q Exp
f [Exp]
params ([Name]
args [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ ['arg]))
       |]

    convertCFunSig :: TH.Type -> [TH.Type] -> TH.TypeQ
    convertCFunSig :: Type -> [Type] -> Q Type
convertCFunSig Type
retType [Type]
params0 = do
      [Type] -> Q Type
go [Type]
params0
      where
        go :: [Type] -> Q Type
go [] =
          [t| IO $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
retType) |]
        go (Type
paramType : [Type]
params) = do
          [t| $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
paramType) -> $([Type] -> Q Type
go [Type]
params) |]


-- NOTE: splitTypedC wouldn't be necessary if inline-c-cpp could reuse C.block
-- internals with a clean interface.
-- This would be a significant refactoring but presumably it would lead to an
-- api that could let users write their own quasiquoters a bit more conveniently.

-- | Returns the type and the body separately.
splitTypedC :: String -> (String, String, Int)
splitTypedC :: String -> (String, String, Int)
splitTypedC String
s = (String -> String
trim String
ty, String
bodyIndent String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
body, Int
bodyLineShift)
  where (String
ty, String
body) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{') String
s
        trim :: String -> String
trim String
x = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd Char -> Bool
C.isSpace ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
C.isSpace String
x)

        -- We may need to correct the line number of the body
        bodyLineShift :: Int
bodyLineShift = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') String
ty)

        -- Indentation is relevant for error messages when the syntax is:
        -- [C.foo| type
        --   { foo(); }
        -- |]
        bodyIndent :: String
bodyIndent =
          let precedingSpaceReversed :: String
precedingSpaceReversed =
                (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
c -> Char -> Bool
C.isSpace Char
c) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                String
ty
              (String
precedingSpacesTabsReversed, String
precedingLine) =
                (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (String
"\n\r" :: [Char])) String
precedingSpaceReversed
          in case String
precedingLine of
            (Char
'\n':String
_) -> String -> String
forall a. [a] -> [a]
reverse String
precedingSpacesTabsReversed
            (Char
'\r':String
_) -> String -> String
forall a. [a] -> [a]
reverse String
precedingSpacesTabsReversed
            String
_ -> String
"" -- it wasn't indentation after all; just spaces after the type

-- | Data to parse for the 'funPtr' quasi-quoter.
data FunPtrDecl = FunPtrDecl
  { FunPtrDecl -> Type CIdentifier
funPtrReturnType :: C.Type C.CIdentifier
  , FunPtrDecl -> [(CIdentifier, Type CIdentifier)]
funPtrParameters :: [(C.CIdentifier, C.Type C.CIdentifier)]
  , FunPtrDecl -> String
funPtrBody :: String
  , FunPtrDecl -> Maybe String
funPtrName :: Maybe String
  } deriving (FunPtrDecl -> FunPtrDecl -> Bool
(FunPtrDecl -> FunPtrDecl -> Bool)
-> (FunPtrDecl -> FunPtrDecl -> Bool) -> Eq FunPtrDecl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FunPtrDecl -> FunPtrDecl -> Bool
== :: FunPtrDecl -> FunPtrDecl -> Bool
$c/= :: FunPtrDecl -> FunPtrDecl -> Bool
/= :: FunPtrDecl -> FunPtrDecl -> Bool
Eq, Int -> FunPtrDecl -> String -> String
[FunPtrDecl] -> String -> String
FunPtrDecl -> String
(Int -> FunPtrDecl -> String -> String)
-> (FunPtrDecl -> String)
-> ([FunPtrDecl] -> String -> String)
-> Show FunPtrDecl
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FunPtrDecl -> String -> String
showsPrec :: Int -> FunPtrDecl -> String -> String
$cshow :: FunPtrDecl -> String
show :: FunPtrDecl -> String
$cshowList :: [FunPtrDecl] -> String -> String
showList :: [FunPtrDecl] -> String -> String
Show)

funPtrQuote :: TH.Safety -> TH.QuasiQuoter
funPtrQuote :: Safety -> QuasiQuoter
funPtrQuote Safety
callSafety = (String -> Q Exp) -> QuasiQuoter
quoteCode ((String -> Q Exp) -> QuasiQuoter)
-> (String -> Q Exp) -> QuasiQuoter
forall a b. (a -> b) -> a -> b
$ \String
rawCode -> do
  loc <- Q Loc
TH.location
  ctx <- getContext
  code <- applySubstitutions rawCode
  FunPtrDecl{..} <- runParserInQ code (C.cCParserContext (ctxEnableCpp ctx) (typeNamesFromTypesTable (ctxTypesTable ctx))) parse
  hsRetType <- cToHs ctx IO funPtrReturnType
  hsParams <- forM funPtrParameters (\(CIdentifier
_ident, Type CIdentifier
typ_) -> Context -> Purity -> Type CIdentifier -> Q Type
cToHs Context
ctx Purity
IO Type CIdentifier
typ_)
  let hsFunType = Type -> [Type] -> Q Type
convertCFunSig Type
hsRetType [Type]
hsParams
  inlineItems callSafety True funPtrName loc hsFunType funPtrReturnType funPtrParameters funPtrBody
  where
    convertCFunSig :: TH.Type -> [TH.Type] -> TH.TypeQ
    convertCFunSig :: Type -> [Type] -> Q Type
convertCFunSig Type
retType [Type]
params0 = do
      [Type] -> Q Type
go [Type]
params0
      where
        go :: [Type] -> Q Type
go [] =
          [t| IO $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
retType) |]
        go (Type
paramType : [Type]
params) = do
          [t| $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
paramType) -> $([Type] -> Q Type
go [Type]
params) |]

    parse :: C.CParser C.CIdentifier m => m FunPtrDecl
    parse :: forall (m :: * -> *). CParser CIdentifier m => m FunPtrDecl
parse = do
      -- skip spaces
      m ()
forall (m :: * -> *). CharParsing m => m ()
Parser.spaces
      -- parse a proto
      C.ParameterDeclaration mbName protoTyp <- m (ParameterDeclaration CIdentifier)
forall i (m :: * -> *).
(CParser i m, Pretty i) =>
m (ParameterDeclaration i)
C.parseParameterDeclaration
      case protoTyp of
        C.Proto Type CIdentifier
retType [ParameterDeclaration CIdentifier]
paramList -> do
          args <- [ParameterDeclaration CIdentifier]
-> (ParameterDeclaration CIdentifier
    -> m (CIdentifier, Type CIdentifier))
-> m [(CIdentifier, Type CIdentifier)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ParameterDeclaration CIdentifier]
paramList ((ParameterDeclaration CIdentifier
  -> m (CIdentifier, Type CIdentifier))
 -> m [(CIdentifier, Type CIdentifier)])
-> (ParameterDeclaration CIdentifier
    -> m (CIdentifier, Type CIdentifier))
-> m [(CIdentifier, Type CIdentifier)]
forall a b. (a -> b) -> a -> b
$ \ParameterDeclaration CIdentifier
decl -> case ParameterDeclaration CIdentifier -> Maybe CIdentifier
forall i. ParameterDeclaration i -> Maybe i
C.parameterDeclarationId ParameterDeclaration CIdentifier
decl of
            Maybe CIdentifier
Nothing -> String -> m (CIdentifier, Type CIdentifier)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (CIdentifier, Type CIdentifier))
-> String -> m (CIdentifier, Type CIdentifier)
forall a b. (a -> b) -> a -> b
$ Doc (ZonkAny 5) -> String
forall ann. Doc ann -> String
pretty80 (Doc (ZonkAny 5) -> String) -> Doc (ZonkAny 5) -> String
forall a b. (a -> b) -> a -> b
$
              Doc (ZonkAny 5)
"Un-named captured variable in decl" Doc (ZonkAny 5) -> Doc (ZonkAny 5) -> Doc (ZonkAny 5)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ParameterDeclaration CIdentifier -> Doc (ZonkAny 5)
forall a ann. Pretty a => a -> Doc ann
forall ann. ParameterDeclaration CIdentifier -> Doc ann
PP.pretty ParameterDeclaration CIdentifier
decl
            Just CIdentifier
declId -> (CIdentifier, Type CIdentifier)
-> m (CIdentifier, Type CIdentifier)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CIdentifier
declId, ParameterDeclaration CIdentifier -> Type CIdentifier
forall i. ParameterDeclaration i -> Type i
C.parameterDeclarationType ParameterDeclaration CIdentifier
decl)
          -- get the rest of the body
          void (Parser.symbolic '{')
          body <- parseBody
          return FunPtrDecl
            { funPtrReturnType = retType
            , funPtrParameters = args
            , funPtrBody = body
            , funPtrName = fmap C.unCIdentifier mbName
            }
        Type CIdentifier
_ -> String -> m FunPtrDecl
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m FunPtrDecl) -> String -> m FunPtrDecl
forall a b. (a -> b) -> a -> b
$ String
"Expecting function declaration"

    parseBody :: C.CParser C.CIdentifier m => m String
    parseBody :: forall (m :: * -> *). CParser CIdentifier m => m String
parseBody = do
      s <- m Char -> m Char -> m String
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m [a]
Parser.manyTill m Char
forall (m :: * -> *). CharParsing m => m Char
Parser.anyChar (m Char -> m String) -> m Char -> m String
forall a b. (a -> b) -> a -> b
$
           m Char -> m Char
forall a. m a -> m a
forall (m :: * -> *) a. LookAheadParsing m => m a -> m a
Parser.lookAhead (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'}')
      s' <- msum
        [ do Parser.try $ do -- Try because we might fail to parse the 'eof'
                -- 'symbolic' because we want to consume whitespace
               void $ Parser.symbolic '}'
               Parser.eof
             return ""
        , do void $ Parser.char '}'
             s' <- parseBody
             return ("}" ++ s')
        ]
      return (s ++ s')

------------------------------------------------------------------------
-- Line directives

-- | Tell the C compiler where the next line came from.
--
-- Example:
--
-- @@@
-- there <- location
-- f (unlines
--   [ lineDirective $(here)
--   , "generated_code_user_did_not_write()"
--   , lineDirective there
--   ] ++ userCode
-- ])
-- @@@
--
-- Use @lineDirective $(C.here)@ when generating code, so that any errors or
-- warnings report the location of the generating haskell module, rather than
-- tangentially related user code that doesn't contain the actual problem.
lineDirective :: TH.Loc -> String
lineDirective :: Loc -> String
lineDirective Loc
l = String
"#line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ((Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Loc -> (Int, Int)
TH.loc_start Loc
l) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Loc -> String
TH.loc_filename Loc
l ) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

-- | Get the location of the code you're looking at, for use with
-- 'lineDirective'; place before generated code that user did not write.
here :: TH.ExpQ
here :: Q Exp
here = [| $(Q Loc
TH.location Q Loc -> (Loc -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(TH.Loc String
a String
b String
c (Int
d1, Int
d2) (Int
e1, Int
e2)) ->
    [|Loc
      $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.lift String
a)
      $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.lift String
b)
      $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.lift String
c)
      ($(Int -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Int -> m Exp
TH.lift Int
d1), $(Int -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Int -> m Exp
TH.lift Int
d2))
      ($(Int -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Int -> m Exp
TH.lift Int
e1), $(Int -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Int -> m Exp
TH.lift Int
e2))
    |])
  |]

shiftLines :: Int -> TH.Loc -> TH.Loc
shiftLines :: Int -> Loc -> Loc
shiftLines Int
n Loc
l = Loc
l
  { TH.loc_start =
      let (startLn, startCol) = TH.loc_start l
      in (startLn + n, startCol)
  , TH.loc_end =
      let (endLn, endCol) = TH.loc_end l
      in (endLn + n, endCol)
  }

------------------------------------------------------------------------
-- Utils

pretty80 :: PP.Doc ann -> String
pretty80 :: forall ann. Doc ann -> String
pretty80 Doc ann
x = SimpleDocStream ann -> String
forall ann. SimpleDocStream ann -> String
PP.renderString (SimpleDocStream ann -> String) -> SimpleDocStream ann -> String
forall a b. (a -> b) -> a -> b
$ LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutSmart (PP.LayoutOptions { layoutPageWidth :: PageWidth
PP.layoutPageWidth = Int -> Double -> PageWidth
PP.AvailablePerLine Int
80 Double
0.8 }) Doc ann
x

prettyOneLine :: PP.Doc ann -> String
prettyOneLine :: forall ann. Doc ann -> String
prettyOneLine Doc ann
x = SimpleDocStream (ZonkAny 0) -> String
forall ann. SimpleDocStream ann -> String
PP.renderString (SimpleDocStream (ZonkAny 0) -> String)
-> SimpleDocStream (ZonkAny 0) -> String
forall a b. (a -> b) -> a -> b
$ Doc ann -> SimpleDocStream (ZonkAny 0)
forall ann1 ann2. Doc ann1 -> SimpleDocStream ann2
PP.layoutCompact Doc ann
x