{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Overloaded.CodeStrings where

import Control.Monad                     (when)
import Data.Char                         (ord)
import Data.Word                         (Word8)
import Language.Haskell.TH               (appE)
import Language.Haskell.TH.Syntax        (lift, reportWarning)
import Language.Haskell.TH.Syntax.Compat (SpliceQ, unsafeSpliceCoerce)

import qualified Data.ByteString as BS

-- | Class for auto-spliced string literals
--
-- The string literals @"beer"@ is desugared into @$$(codeFromString \@"beer")@ splice.
--
-- @
-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:CodeLabels #-}
-- @
--
-- This feature is not very usable, see https://gitlab.haskell.org/ghc/ghc/-/issues/18211
class IsCodeString a where
    codeFromString :: String -> SpliceQ a

instance a ~ Char => IsCodeString [a] where
    codeFromString :: String -> SpliceQ [a]
codeFromString = Q Exp -> SpliceQ [a]
forall a (m :: * -> *). Quote m => m Exp -> Splice m a
unsafeSpliceCoerce (Q Exp -> SpliceQ [a])
-> (String -> Q Exp) -> String -> SpliceQ [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
forall t. Lift t => t -> Q Exp
lift

instance IsCodeString BS.ByteString where
    codeFromString :: String -> SpliceQ ByteString
codeFromString String
str = Q Exp -> SpliceQ ByteString
forall a (m :: * -> *). Quote m => m Exp -> Splice m a
unsafeSpliceCoerce (Q Exp -> SpliceQ ByteString) -> Q Exp -> SpliceQ ByteString
forall a b. (a -> b) -> a -> b
$ do
        Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
> Char
'\255') String
str ) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
            String -> Q ()
reportWarning String
"Splicing non-ASCII ByteString"

        let octets :: [Word8]
            octets :: [Word8]
octets = (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) String
str

        [| BS.pack |] Q Exp -> Q Exp -> Q Exp
`appE` [Word8] -> Q Exp
forall t. Lift t => t -> Q Exp
lift [Word8]
octets