{-# LANGUAGE CPP               #-}
{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.Sexp.Token
  ( Token (..)
  , Prefix (..)
  , escape
  , unescape
  ) where

import Data.Scientific
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif
import Data.Text (Text)
import qualified Data.Text.Lazy as TL

#if MIN_VERSION_prettyprinter(1,7,0)
import Prettyprinter
#else
import Data.Text.Prettyprint.Doc
#endif

import Language.Sexp.Types (Prefix(..))

data Token
  = TokLParen          -- (
  | TokRParen          -- )
  | TokLBracket        -- [
  | TokRBracket        -- ]
  | TokLBrace          -- {
  | TokRBrace          -- }
  | TokPrefix  { Token -> Prefix
getPrefix  :: !Prefix }      -- e.g. a quote in '(foo bar)
  | TokNumber  { Token -> Scientific
getNumber  :: !Scientific }  -- 42.0, -1.0, 3.14, -1e10
  | TokString  { Token -> Text
getString  :: !Text }        -- "foo", "", "hello world"
  | TokSymbol  { Token -> Text
getSymbol  :: !Text }        -- foo, bar
  | TokUnknown { Token -> Text
getUnknown :: !Text }        -- for unknown lexemes
  | TokEOF
    deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show, Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq)

instance Pretty Token where
  pretty :: Token -> Doc ann
pretty Token
TokLParen      = Doc ann
"left paren '('"
  pretty Token
TokRParen      = Doc ann
"right paren ')'"
  pretty Token
TokLBracket    = Doc ann
"left bracket '['"
  pretty Token
TokRBracket    = Doc ann
"right bracket '['"
  pretty Token
TokLBrace      = Doc ann
"left brace '{'"
  pretty Token
TokRBrace      = Doc ann
"right brace '}'"
  pretty (TokPrefix Prefix
c)  = Doc ann
"modifier" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Prefix -> String
forall a. Show a => a -> String
show Prefix
c)
  pretty (TokSymbol Text
s)  = Doc ann
"symbol" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
squotes (Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
s) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
squote
  pretty (TokNumber Scientific
n)  = Doc ann
"number" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Scientific -> String
forall a. Show a => a -> String
show Scientific
n)
  pretty (TokString Text
s)  = Doc ann
"string" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> String
forall a. Show a => a -> String
show Text
s)
  pretty (TokUnknown Text
u) = Doc ann
"unrecognized" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
u Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"..."
  pretty Token
TokEOF         = Doc ann
"end of file"


newtype DText = DText (TL.Text -> TL.Text)

instance Semigroup DText where
  DText Text -> Text
a <> :: DText -> DText -> DText
<> DText Text -> Text
b = (Text -> Text) -> DText
DText (Text -> Text
a (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
b)

instance Monoid DText where
  mempty :: DText
mempty = (Text -> Text) -> DText
DText Text -> Text
forall a. a -> a
id
  mappend :: DText -> DText -> DText
mappend = DText -> DText -> DText
forall a. Semigroup a => a -> a -> a
(<>)

delay :: TL.Text -> DText
delay :: Text -> DText
delay Text
t = (Text -> Text) -> DText
DText (Text
t Text -> Text -> Text
`TL.append`)

force :: DText -> TL.Text
force :: DText -> Text
force (DText Text -> Text
f) = Text -> Text
f Text
TL.empty


unescape :: TL.Text -> TL.Text
unescape :: Text -> Text
unescape = DText -> Text
force (DText -> Text) -> (Text -> DText) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DText -> Text -> DText
go DText
forall a. Monoid a => a
mempty
  where
    go :: DText -> TL.Text -> DText
    go :: DText -> Text -> DText
go DText
acc Text
text
      | Text -> Bool
TL.null Text
text = DText
acc
      | Bool
otherwise =
         let (Text
chunk, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
TL.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\') Text
text in
         case Text -> Maybe (Char, Text)
TL.uncons Text
rest of
           Maybe (Char, Text)
Nothing -> DText
acc DText -> DText -> DText
forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay Text
chunk
           Just (Char
_, Text
rest') ->
             case Text -> Maybe (Char, Text)
TL.uncons Text
rest' of
               Maybe (Char, Text)
Nothing -> String -> DText
forall a. HasCallStack => String -> a
error String
"Invalid escape sequence"
               Just (Char
'n', Text
rest'') -> DText -> Text -> DText
go (DText
acc DText -> DText -> DText
forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay (Text
chunk Text -> Char -> Text
`TL.snoc` Char
'\n')) Text
rest''
               Just (Char
'r', Text
rest'') -> DText -> Text -> DText
go (DText
acc DText -> DText -> DText
forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay (Text
chunk Text -> Char -> Text
`TL.snoc` Char
'\r')) Text
rest''
               Just (Char
't', Text
rest'') -> DText -> Text -> DText
go (DText
acc DText -> DText -> DText
forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay (Text
chunk Text -> Char -> Text
`TL.snoc` Char
'\t')) Text
rest''
               Just (Char
lit, Text
rest'') -> DText -> Text -> DText
go (DText
acc DText -> DText -> DText
forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay (Text
chunk Text -> Char -> Text
`TL.snoc` Char
lit )) Text
rest''


escape :: TL.Text -> TL.Text
escape :: Text -> Text
escape = DText -> Text
force (DText -> Text) -> (Text -> DText) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DText -> Text -> DText
go DText
forall a. Monoid a => a
mempty
  where
    go :: DText -> TL.Text -> DText
    go :: DText -> Text -> DText
go DText
acc Text
text
      | Text -> Bool
TL.null Text
text = DText
acc
      | Bool
otherwise =
          let (Text
chunk, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
TL.break (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\') Text
text
          in case Text -> Maybe (Char, Text)
TL.uncons Text
rest of
               Maybe (Char, Text)
Nothing -> DText
acc DText -> DText -> DText
forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay Text
chunk
               Just (Char
'"', Text
rest') -> DText -> Text -> DText
go (DText
acc DText -> DText -> DText
forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay Text
chunk DText -> DText -> DText
forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay Text
"\\\"") Text
rest'
               Just (Char
'\\',Text
rest') -> DText -> Text -> DText
go (DText
acc DText -> DText -> DText
forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay Text
chunk DText -> DText -> DText
forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay Text
"\\\\") Text
rest'
               Just (Char
other, Text
rest') -> DText -> Text -> DText
go (DText
acc DText -> DText -> DText
forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay Text
chunk DText -> DText -> DText
forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay (Char -> Text
TL.singleton Char
other)) Text
rest'