{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}

-- |
-- Module: Text.Ascii.QQ
-- Copyright: (C) 2021 Koz Ross
-- License: Apache 2.0
-- Maintainer: Koz Ross <koz.ross@retro-freedom.nz>
-- Stability: unstable, not subject to PVP
-- Portability: GHC only
--
-- This is an internal module, and is /not/ subject to the PVP. It can change
-- in any way, at any time, and should not be depended on unless you know
-- /exactly/ what you are doing. You have been warned.
module Text.Ascii.QQ where

import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Char
  ( isAlphaNum,
    isAscii,
    isPunctuation,
    isSymbol,
    ord,
  )
import Data.Functor (void)
import Data.Void (Void)
import GHC.Exts (IsList (fromList))
import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))
import Language.Haskell.TH.Syntax
  ( Dec,
    Exp (AppE, ConE, ListE, LitE, VarE),
    Lit (IntegerL),
    Pat,
    Q,
    Type,
  )
import Text.Ascii.Internal (AsciiChar (AsciiChar), AsciiText (AsciiText))
import Text.Megaparsec
  ( Parsec,
    between,
    eof,
    lookAhead,
    manyTill,
    oneOf,
    parse,
    satisfy,
    single,
    try,
  )
import Text.Megaparsec.Char (space)
import Text.Megaparsec.Error (errorBundlePretty)

-- $setup
-- >>> :set -XQuasiQuotes
-- >>> import Text.Ascii.QQ

-- | Allows constructing ASCII characters from literals, whose correctness is
-- checked by the compiler.
--
-- Currently, accepts literal syntax similar to the Haskell parser, with escape
-- sequences preceded by \'\\\'. In particular, this includes the single quote
-- (see the example below).
--
-- >>> [char| '\'' |]
-- '0x27'
--
-- @since 1.0.0
char :: QuasiQuoter
char :: QuasiQuoter
char = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter String -> Q Exp
charQQ (String -> String -> Q Pat
errPat String
"char") (String -> String -> Q Type
errType String
"char") (String -> String -> Q [Dec]
errDec String
"char")

-- | Allows constructing ASCII strings from literals, whose correctness is
-- checked by the compiler.
--
-- Currently accepts literal syntax similar to the Haskell parser, with escape
-- sequences preceded by \'\\\'. In particular, this includes the double quote
-- (see the example below).
--
-- >>> [ascii| "\"Nyan!\", said the catboy." |]
-- "\"Nyan!\", said the catboy."
--
-- @since 1.0.0
ascii :: QuasiQuoter
ascii :: QuasiQuoter
ascii = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter String -> Q Exp
asciiQQ (String -> String -> Q Pat
errPat String
"ascii") (String -> String -> Q Type
errType String
"ascii") (String -> String -> Q [Dec]
errDec String
"ascii")

-- Helpers

asciiQQ :: String -> Q Exp
asciiQQ :: String -> Q Exp
asciiQQ String
input = case Parsec Void String ByteString
-> String
-> String
-> Either (ParseErrorBundle String Void) ByteString
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> Parsec Void String ByteString
-> Parsec Void String ByteString
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ParsecT Void String Identity ()
open ParsecT Void String Identity ()
close Parsec Void String ByteString
go) String
"" String
input of
  Left ParseErrorBundle String Void
err -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp)
-> (ParseErrorBundle String Void -> String)
-> ParseErrorBundle String Void
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty (ParseErrorBundle String Void -> Q Exp)
-> ParseErrorBundle String Void -> Q Exp
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle String Void
err
  Right ByteString
result ->
    Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Exp -> Q Exp) -> (ByteString -> Exp) -> ByteString -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'AsciiText)
      (Exp -> Exp) -> (ByteString -> Exp) -> ByteString -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'fromList)
      (Exp -> Exp) -> (ByteString -> Exp) -> ByteString -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
ListE
      ([Exp] -> Exp) -> (ByteString -> [Exp]) -> ByteString -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Exp) -> [Word8] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Lit -> Exp
LitE (Lit -> Exp) -> (Word8 -> Lit) -> Word8 -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Lit) -> (Word8 -> Integer) -> Word8 -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral)
      ([Word8] -> [Exp])
-> (ByteString -> [Word8]) -> ByteString -> [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack
      (ByteString -> Q Exp) -> ByteString -> Q Exp
forall a b. (a -> b) -> a -> b
$ ByteString
result
  where
    open :: Parsec Void String ()
    open :: ParsecT Void String Identity ()
open = ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParsecT Void String Identity (Token String)
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String Identity (Token String)
 -> ParsecT Void String Identity ())
-> (Char -> ParsecT Void String Identity (Token String))
-> Char
-> ParsecT Void String Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single (Char -> ParsecT Void String Identity ())
-> Char -> ParsecT Void String Identity ()
forall a b. (a -> b) -> a -> b
$ Char
'"')
    close :: Parsec Void String ()
    close :: ParsecT Void String Identity ()
close = Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token String
'"' ParsecT Void String Identity (Token String)
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
    go :: Parsec Void String ByteString
    go :: Parsec Void String ByteString
go = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString)
-> ParsecT Void String Identity [Word8]
-> Parsec Void String ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity Word8
-> ParsecT Void String Identity (Token String)
-> ParsecT Void String Identity [Word8]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ParsecT Void String Identity Word8
asciiByte (ParsecT Void String Identity (Token String)
-> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (ParsecT Void String Identity (Token String)
 -> ParsecT Void String Identity (Token String))
-> (Char -> ParsecT Void String Identity (Token String))
-> Char
-> ParsecT Void String Identity (Token String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void String Identity (Token String)
-> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String Identity (Token String)
 -> ParsecT Void String Identity (Token String))
-> (Char -> ParsecT Void String Identity (Token String))
-> Char
-> ParsecT Void String Identity (Token String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single (Char -> ParsecT Void String Identity (Token String))
-> Char -> ParsecT Void String Identity (Token String)
forall a b. (a -> b) -> a -> b
$ Char
'"')
    asciiByte :: ParsecT Void String Identity Word8
asciiByte = do
      Char
c <- (Token String -> Bool)
-> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token String -> Bool
isAscii
      case Char
c of
        Char
'\\' -> do
          Char
c' <- [Token String] -> ParsecT Void String Identity (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf String
[Token String]
"0abfnrtv\\\""
          Word8 -> ParsecT Void String Identity Word8
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> ParsecT Void String Identity Word8)
-> (Char -> Word8) -> Char -> ParsecT Void String Identity Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (Char -> ParsecT Void String Identity Word8)
-> Char -> ParsecT Void String Identity Word8
forall a b. (a -> b) -> a -> b
$ case Char
c' of
            Char
'0' -> Char
'\0'
            Char
'a' -> Char
'\a'
            Char
'b' -> Char
'\b'
            Char
'f' -> Char
'\f'
            Char
'n' -> Char
'\n'
            Char
'r' -> Char
'\r'
            Char
't' -> Char
'\t'
            Char
'v' -> Char
'\v'
            Char
'\\' -> Char
'\\'
            Char
_ -> Char
'"'
        Char
_ -> Word8 -> ParsecT Void String Identity Word8
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> ParsecT Void String Identity Word8)
-> (Char -> Word8) -> Char -> ParsecT Void String Identity Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (Char -> ParsecT Void String Identity Word8)
-> Char -> ParsecT Void String Identity Word8
forall a b. (a -> b) -> a -> b
$ Char
c

charQQ :: String -> Q Exp
charQQ :: String -> Q Exp
charQQ String
input = case Parsec Void String Int
-> String -> String -> Either (ParseErrorBundle String Void) Int
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> Parsec Void String Int
-> Parsec Void String Int
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ParsecT Void String Identity ()
open ParsecT Void String Identity ()
close Parsec Void String Int
go) String
"" String
input of
  Left ParseErrorBundle String Void
err -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp)
-> (ParseErrorBundle String Void -> String)
-> ParseErrorBundle String Void
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty (ParseErrorBundle String Void -> Q Exp)
-> ParseErrorBundle String Void -> Q Exp
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle String Void
err
  Right Int
result ->
    Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> (Int -> Exp) -> Int -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'AsciiChar) (Exp -> Exp) -> (Int -> Exp) -> Int -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE (Lit -> Exp) -> (Int -> Lit) -> Int -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Lit) -> (Int -> Integer) -> Int -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Q Exp) -> Int -> Q Exp
forall a b. (a -> b) -> a -> b
$ Int
result
  where
    open :: Parsec Void String ()
    open :: ParsecT Void String Identity ()
open = ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParsecT Void String Identity (Token String)
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String Identity (Token String)
 -> ParsecT Void String Identity ())
-> (Char -> ParsecT Void String Identity (Token String))
-> Char
-> ParsecT Void String Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single (Char -> ParsecT Void String Identity ())
-> Char -> ParsecT Void String Identity ()
forall a b. (a -> b) -> a -> b
$ Char
'\'')
    close :: Parsec Void String ()
    close :: ParsecT Void String Identity ()
close = Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token String
'\'' ParsecT Void String Identity (Token String)
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
    go :: Parsec Void String Int
    go :: Parsec Void String Int
go = do
      Char
c1 <- (Token String -> Bool)
-> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token String -> Bool
isValidLead
      case Char
c1 of
        Char
'\\' -> do
          Char
c2 <- [Token String] -> ParsecT Void String Identity (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf String
[Token String]
"0abfnrtv\\\'"
          Int -> Parsec Void String Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Parsec Void String Int)
-> (Char -> Int) -> Char -> Parsec Void String Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord (Char -> Parsec Void String Int) -> Char -> Parsec Void String Int
forall a b. (a -> b) -> a -> b
$ case Char
c2 of
            Char
'0' -> Char
'\0'
            Char
'a' -> Char
'\a'
            Char
'b' -> Char
'\b'
            Char
'f' -> Char
'\f'
            Char
'n' -> Char
'\n'
            Char
'r' -> Char
'\r'
            Char
't' -> Char
'\t'
            Char
'v' -> Char
'\v'
            Char
'\\' -> Char
'\\'
            Char
_ -> Char
'\''
        Char
_ -> Int -> Parsec Void String Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Parsec Void String Int)
-> (Char -> Int) -> Char -> Parsec Void String Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord (Char -> Parsec Void String Int) -> Char -> Parsec Void String Int
forall a b. (a -> b) -> a -> b
$ Char
c1

isValidLead :: Char -> Bool
isValidLead :: Char -> Bool
isValidLead Char
c = Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& (Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char -> Bool
isSymbol Char
c Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c)

errPat :: String -> String -> Q Pat
errPat :: String -> String -> Q Pat
errPat String
name String
_ = String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Pat) -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' should not be used in a pattern context."

errType :: String -> String -> Q Type
errType :: String -> String -> Q Type
errType String
name String
_ = String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' should not be used in a type context."

errDec :: String -> String -> Q [Dec]
errDec :: String -> String -> Q [Dec]
errDec String
name String
_ = String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' should not be used in a declaration context."