Anonymous foreign import

AnonForeign.hs

{-# LANGUAGE RecordWildCards, LambdaCase #-}

module AnonForeign(foreignImport) where

import Control.Applicative
import Control.Monad
import Language.Haskell.Meta.Parse
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import System.Random
import Text.ParserCombinators.Parsec as P hiding ((<|>))
import Text.ParserCombinators.Parsec.Language (haskellDef)
import qualified Text.ParserCombinators.Parsec.Token as PT

PT.TokenParser { .. } = PT.makeTokenParser haskellDef

foreignImport :: QuasiQuoter
foreignImport = QuasiQuoter { quoteExp = quoteForeign }
  where
    quoteForeign s = case parse parseForeign "" s of
      Left err -> fail (show err)
      Right ( cconv, safety, spec, type_ ) -> do
        nameSuf <- runIO $ replicateM 16 $ randomRIO ( 'a', 'z' ) -- hack hack hack
        name <- newName ("foreign_anon_" ++ nameSuf)
        addTopDecls [ ForeignD $ ImportF cconv safety spec name type_ ]
        return $ VarE name

parseForeign :: Parser ( Callconv, Safety, String, Type )
parseForeign = do
  whiteSpace
  cconv <- CCall <$ reserved "ccall"
       <|> StdCall <$ reserved "stdcall"
  safety <- Unsafe <$ reserved "unsafe"
        <|> Interruptible <$ reserved "interruptible"
        <|> Safe <$ reserved "safe"
        <|> pure Safe
  spec <- stringLiteral
  reservedOp "::"
  typeString <- P.many anyToken
  type_ <- case parseType typeString of
    Left err -> fail err
    Right t -> return t
  return ( cconv, safety, spec, type_ )

{- TEST

import AnonForeign

import qualified Data.ByteString as BS
import Foreign.C

test = BS.useAsCString "oh baby" [foreignImport|ccall  safe "stdio.h puts" :: CString -> IO CInt |]
test2 = BS.useAsCString "kaching" [foreignImport| ccall  safe "stdio.h puts" :: CString -> IO CInt |]

-}