module Text.Haiji.Syntax.Literal.String
       ( StringLiteral
       , stringLiteral
       , unwrap
       ) where

import Data.Attoparsec.Text hiding (string)

-- $setup
-- >>> import Control.Arrow (left)

data StringLiteral = SingleQuotedStringLiteral String
                   | DoubleQuotedStringLiteral String
                   deriving StringLiteral -> StringLiteral -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StringLiteral -> StringLiteral -> Bool
$c/= :: StringLiteral -> StringLiteral -> Bool
== :: StringLiteral -> StringLiteral -> Bool
$c== :: StringLiteral -> StringLiteral -> Bool
Eq

unwrap :: StringLiteral -> String
unwrap :: StringLiteral -> String
unwrap (SingleQuotedStringLiteral String
s) = String
s
unwrap (DoubleQuotedStringLiteral String
s) = String
s

instance Show StringLiteral where
  show :: StringLiteral -> String
show (SingleQuotedStringLiteral String
str) = Char
'\'' forall a. a -> [a] -> [a]
: (String
str forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> String
escape) forall a. [a] -> [a] -> [a]
++ String
"'"  where
    escape :: Char -> String
escape Char
c = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char
c] forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
c forall a b. (a -> b) -> a -> b
$ (Char
'\'', String
"\\'") forall a. a -> [a] -> [a]
: [(Char, String)]
requireEscape
  show (DoubleQuotedStringLiteral String
str) = Char
'"' forall a. a -> [a] -> [a]
: (String
str forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> String
escape) forall a. [a] -> [a] -> [a]
++ String
"\"" where
    escape :: Char -> String
escape Char
c = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char
c] forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
c forall a b. (a -> b) -> a -> b
$ (Char
'"', String
"\\\"") forall a. a -> [a] -> [a]
: [(Char, String)]
requireEscape

-- |
--
-- >>> let eval = left (const "parse error") . parseOnly stringLiteral
-- >>> eval "'test'"
-- Right 'test'
-- >>> eval "\"test\""
-- Right "test"
-- >>> eval "'\\\'\"'"
-- Right '\'"'
-- >>> eval "\"\'\\\"\""
-- Right "'\""
stringLiteral :: Parser StringLiteral
stringLiteral :: Parser StringLiteral
stringLiteral = forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [ Char -> Parser Char
char Char
'\'' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> StringLiteral
SingleQuotedStringLiteral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser String
quotedBy Char
'\'')
                       , Char -> Parser Char
char Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> StringLiteral
DoubleQuotedStringLiteral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser String
quotedBy Char
'"')
                       ]

requireUnescape :: [(Char, Char)]
requireUnescape :: [(Char, Char)]
requireUnescape = [ (Char
'n', Char
'\n')
                  , (Char
'r', Char
'\r')
                  , (Char
'b', Char
'\b')
                  , (Char
'v', Char
'\v')
                  , (Char
'0', Char
'\0')
                  , (Char
't', Char
'\t')
                  ]

requireEscape :: [(Char, String)]
requireEscape :: [(Char, String)]
requireEscape = [ (Char
b, [Char
'\\', Char
a]) | (Char
a, Char
b) <- [(Char, Char)]
requireUnescape ]

quotedBy :: Char -> Parser String
quotedBy :: Char -> Parser String
quotedBy = forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill Parser Char
contents forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Parser Char
char where
  contents :: Parser Char
  contents :: Parser Char
contents = do
    Char
c <- Parser Char
anyChar
    case Char
c of
      Char
'\\' -> do
        Char
escaped <- Parser Char
anyChar
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Char
escaped forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
escaped [(Char, Char)]
requireUnescape
      Char
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Char
c