{-# 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 }
| TokNumber { Token -> Scientific
getNumber :: !Scientific }
| TokString { Token -> Text
getString :: !Text }
| TokSymbol { Token -> Text
getSymbol :: !Text }
| TokUnknown { Token -> Text
getUnknown :: !Text }
| 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'