{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}


module Data.IOEmbed (embedIO, embedIOLit, toLitE) where

import Language.Haskell.TH
import Data.Typeable (Typeable, Proxy (..), typeRep, cast)
import qualified Data.ByteString as B8
import Data.ByteString(ByteString)
import Data.ByteString.Internal (ByteString(..))
import Data.Maybe(fromJust)
import System.IO.Unsafe (unsafePerformIO)
import Data.ByteString.Unsafe (unsafePackAddressLen)

-- | Embeds an `IO` a value - as long as `a` is `Char`, `String`,  'Integer', `Rational`, or `ByteString`.
-- 
-- > {-# LANGUAGE TemplateHaskell #-}
-- >
-- > fileContent = $(embedIO $ readFile "./README.md")
-- 
embedIO :: forall a.  Typeable a => IO a -> Q Exp
embedIO :: forall a. Typeable a => IO a -> Q Exp
embedIO = IO Exp -> Q Exp
forall a. IO a -> Q a
runIO (IO Exp -> Q Exp) -> (IO a -> IO Exp) -> IO a -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Exp) -> IO a -> IO Exp
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Exp
forall a. Typeable a => a -> Exp
toLitE

-- | If you want to embed something else, you can manually generate an `IO` `Lit` and use this function. 
-- 
-- > {-# LANGUAGE TemplateHaskell #-}
-- >
-- > fileContentL = $(embedIOLit $ StringL <$> readFile "./README.md")
-- 
embedIOLit :: IO Lit -> Q Exp
embedIOLit :: IO Lit -> Q Exp
embedIOLit = IO Exp -> Q Exp
forall a. IO a -> Q a
runIO (IO Exp -> Q Exp) -> (IO Lit -> IO Exp) -> IO Lit -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lit -> Exp) -> IO Lit -> IO Exp
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Lit -> Exp
LitE

-- | Converts `Char`, `String`,  'Integer', `Rational`, or `ByteString` to a literal expression.
toLitE :: forall a. Typeable a => a -> Exp
toLitE :: forall a. Typeable a => a -> Exp
toLitE a
x
  | TypeRep
typeRep' TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy Char -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy Char
forall {k} (t :: k). Proxy t
Proxy :: Proxy Char)       = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ Char -> Lit
CharL     (Char -> Lit) -> Char -> Lit
forall a b. (a -> b) -> a -> b
$ Maybe Char -> Char
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Char -> Char) -> Maybe Char -> Char
forall a b. (a -> b) -> a -> b
$ a -> Maybe Char
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x
  | TypeRep
typeRep' TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy String -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy String
forall {k} (t :: k). Proxy t
Proxy :: Proxy String)     = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL   (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ a -> Maybe String
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x
  | TypeRep
typeRep' TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy Integer -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy Integer
forall {k} (t :: k). Proxy t
Proxy :: Proxy Integer)    = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL  (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> Integer
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Integer -> Integer) -> Maybe Integer -> Integer
forall a b. (a -> b) -> a -> b
$ a -> Maybe Integer
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x
  | TypeRep
typeRep' TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy Rational -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy Rational
forall {k} (t :: k). Proxy t
Proxy :: Proxy Rational)   = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ Rational -> Lit
RationalL (Rational -> Lit) -> Rational -> Lit
forall a b. (a -> b) -> a -> b
$ Maybe Rational -> Rational
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Rational -> Rational) -> Maybe Rational -> Rational
forall a b. (a -> b) -> a -> b
$ a -> Maybe Rational
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x
  -- Special types
  | TypeRep
typeRep' TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy ByteString -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy ByteString
forall {k} (t :: k). Proxy t
Proxy :: Proxy ByteString) = let
                                                        bs :: ByteString
bs = Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> Maybe ByteString
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x 
                                                        PS ForeignPtr Word8
ptr Int
off Int
sz = ByteString
bs
                                                      in Name -> Exp
VarE 'unsafePerformIO
                                                      Exp -> Exp -> Exp
`AppE`  (Name -> Exp
VarE 'unsafePackAddressLen Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (Integer -> Lit
IntegerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B8.length ByteString
bs)
                                                      Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (Bytes -> Lit
bytesPrimL (Bytes -> Lit) -> Bytes -> Lit
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Word -> Word -> Bytes
mkBytes ForeignPtr Word8
ptr (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz)))
                                                        

  | Bool
otherwise = String -> Exp
forall a. HasCallStack => String -> a
error (String -> Exp) -> String -> Exp
forall a b. (a -> b) -> a -> b
$ String
"Type " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show TypeRep
typeRep' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not embeddable" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                        String
"\nEmbeddable types are: Char, String, Integer, Rational, ByteString"
  where typeRep' :: TypeRep
typeRep' = Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)