{-# 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          -- }
  | TokCommentIntro    -- #;
  | 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
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
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 :: forall ann. 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 Token
TokCommentIntro = Doc ann
"datum comment"
  pretty (TokPrefix Prefix
c)   = Doc ann
"modifier" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show Prefix
c)
  pretty (TokSymbol Text
s)   = Doc ann
"symbol" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
squotes (forall a ann. Pretty a => a -> Doc ann
pretty Text
s) forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
squote
  pretty (TokNumber Scientific
n)   = Doc ann
"number" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show Scientific
n)
  pretty (TokString Text
s)   = Doc ann
"string" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show Text
s)
  pretty (TokUnknown Text
u)  = Doc ann
"unrecognized" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Text
u 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
b)

instance Monoid DText where
  mempty :: DText
mempty = (Text -> Text) -> DText
DText forall a. a -> a
id
  mappend :: DText -> DText -> DText
mappend = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. DText -> Text -> DText
go 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 (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 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 -> forall a. HasCallStack => String -> a
error String
"Invalid escape sequence"
               Just (Char
'n', Text
rest'') -> DText -> Text -> DText
go (DText
acc 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 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 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. DText -> Text -> DText
go 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 forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c 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 forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay Text
chunk
               Just (Char
'"', Text
rest') -> DText -> Text -> DText
go (DText
acc forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay Text
chunk forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay Text
"\\\"") Text
rest'
               Just (Char
'\\',Text
rest') -> DText -> Text -> DText
go (DText
acc forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay Text
chunk forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay Text
"\\\\") Text
rest'
               Just (Char
other, Text
rest') -> DText -> Text -> DText
go (DText
acc forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay Text
chunk forall a. Semigroup a => a -> a -> a
<> Text -> DText
delay (Char -> Text
TL.singleton Char
other)) Text
rest'