{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
-- |
--
-- Parsers and builders for whitespace characters in our JSON.
--
module Waargonaut.Types.Whitespace
  (
    Whitespace (..)
  , WS (..)
  , _WhitespaceChar

  , escapedWhitespaceChar
  , unescapedWhitespaceChar

  , oneWhitespace
  , parseWhitespace
  , parseSomeWhitespace

  ) where

import           Control.Applicative     (liftA2)
import           Control.Lens            (AsEmpty (..), Cons (..), Prism',
                                          Rewrapped, Wrapped (..), iso,
                                          mapped, nearly, over, prism, prism',
                                          to, uncons, (^.), _2, _Wrapped)
import           Control.Lens.Extras     (is)

import           Data.Vector             (Vector)
import qualified Data.Vector             as V

import           Data.List.NonEmpty      (NonEmpty ((:|)))

import           Data.Foldable           (asum)
#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup          (Semigroup(..))
#endif

import           Text.Parser.Char        (CharParsing, char, newline, tab)
import           Text.Parser.Combinators (many)

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Control.Monad (return)
-- >>> import Data.Either(Either (..), isLeft)
-- >>> import qualified Data.Digit as D
-- >>> import Waargonaut.Decode.Error (DecodeError)
-- >>> import Data.ByteString.Lazy (toStrict)
-- >>> import Data.ByteString.Builder (toLazyByteString)
-- >>> import Utils
----

-- | Represent the different types of whitespace.
data Whitespace
  = Space
  | HorizontalTab
  | LineFeed
  | NewLine
  | CarriageReturn
  deriving (Whitespace -> Whitespace -> Bool
(Whitespace -> Whitespace -> Bool)
-> (Whitespace -> Whitespace -> Bool) -> Eq Whitespace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Whitespace -> Whitespace -> Bool
$c/= :: Whitespace -> Whitespace -> Bool
== :: Whitespace -> Whitespace -> Bool
$c== :: Whitespace -> Whitespace -> Bool
Eq, Eq Whitespace
Eq Whitespace
-> (Whitespace -> Whitespace -> Ordering)
-> (Whitespace -> Whitespace -> Bool)
-> (Whitespace -> Whitespace -> Bool)
-> (Whitespace -> Whitespace -> Bool)
-> (Whitespace -> Whitespace -> Bool)
-> (Whitespace -> Whitespace -> Whitespace)
-> (Whitespace -> Whitespace -> Whitespace)
-> Ord Whitespace
Whitespace -> Whitespace -> Bool
Whitespace -> Whitespace -> Ordering
Whitespace -> Whitespace -> Whitespace
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Whitespace -> Whitespace -> Whitespace
$cmin :: Whitespace -> Whitespace -> Whitespace
max :: Whitespace -> Whitespace -> Whitespace
$cmax :: Whitespace -> Whitespace -> Whitespace
>= :: Whitespace -> Whitespace -> Bool
$c>= :: Whitespace -> Whitespace -> Bool
> :: Whitespace -> Whitespace -> Bool
$c> :: Whitespace -> Whitespace -> Bool
<= :: Whitespace -> Whitespace -> Bool
$c<= :: Whitespace -> Whitespace -> Bool
< :: Whitespace -> Whitespace -> Bool
$c< :: Whitespace -> Whitespace -> Bool
compare :: Whitespace -> Whitespace -> Ordering
$ccompare :: Whitespace -> Whitespace -> Ordering
$cp1Ord :: Eq Whitespace
Ord, Int -> Whitespace -> ShowS
[Whitespace] -> ShowS
Whitespace -> String
(Int -> Whitespace -> ShowS)
-> (Whitespace -> String)
-> ([Whitespace] -> ShowS)
-> Show Whitespace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Whitespace] -> ShowS
$cshowList :: [Whitespace] -> ShowS
show :: Whitespace -> String
$cshow :: Whitespace -> String
showsPrec :: Int -> Whitespace -> ShowS
$cshowsPrec :: Int -> Whitespace -> ShowS
Show)

-- | This is a wrapper for a sequence of consecutive whitespace.
newtype WS = WS (Vector Whitespace)
  deriving (WS -> WS -> Bool
(WS -> WS -> Bool) -> (WS -> WS -> Bool) -> Eq WS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WS -> WS -> Bool
$c/= :: WS -> WS -> Bool
== :: WS -> WS -> Bool
$c== :: WS -> WS -> Bool
Eq, Int -> WS -> ShowS
[WS] -> ShowS
WS -> String
(Int -> WS -> ShowS)
-> (WS -> String) -> ([WS] -> ShowS) -> Show WS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WS] -> ShowS
$cshowList :: [WS] -> ShowS
show :: WS -> String
$cshow :: WS -> String
showsPrec :: Int -> WS -> ShowS
$cshowsPrec :: Int -> WS -> ShowS
Show)

instance Cons WS WS Whitespace Whitespace where
  _Cons :: p (Whitespace, WS) (f (Whitespace, WS)) -> p WS (f WS)
_Cons = ((Whitespace, WS) -> WS)
-> (WS -> Maybe (Whitespace, WS))
-> Prism WS WS (Whitespace, WS) (Whitespace, WS)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (\(Whitespace
w,WS
ws) -> ASetter WS WS (Vector Whitespace) (Vector Whitespace)
-> (Vector Whitespace -> Vector Whitespace) -> WS -> WS
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter WS WS (Vector Whitespace) (Vector Whitespace)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped (Whitespace -> Vector Whitespace -> Vector Whitespace
forall a. a -> Vector a -> Vector a
V.cons Whitespace
w) WS
ws) (\(WS Vector Whitespace
ws) -> ASetter
  (Maybe (Whitespace, Vector Whitespace))
  (Maybe (Whitespace, WS))
  (Vector Whitespace)
  WS
-> (Vector Whitespace -> WS)
-> Maybe (Whitespace, Vector Whitespace)
-> Maybe (Whitespace, WS)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((Whitespace, Vector Whitespace) -> Identity (Whitespace, WS))
-> Maybe (Whitespace, Vector Whitespace)
-> Identity (Maybe (Whitespace, WS))
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped (((Whitespace, Vector Whitespace) -> Identity (Whitespace, WS))
 -> Maybe (Whitespace, Vector Whitespace)
 -> Identity (Maybe (Whitespace, WS)))
-> ((Vector Whitespace -> Identity WS)
    -> (Whitespace, Vector Whitespace) -> Identity (Whitespace, WS))
-> ASetter
     (Maybe (Whitespace, Vector Whitespace))
     (Maybe (Whitespace, WS))
     (Vector Whitespace)
     WS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Whitespace -> Identity WS)
-> (Whitespace, Vector Whitespace) -> Identity (Whitespace, WS)
forall s t a b. Field2 s t a b => Lens s t a b
_2) Vector Whitespace -> WS
WS (Vector Whitespace -> Maybe (Whitespace, Vector Whitespace)
forall s a. Cons s s a a => s -> Maybe (a, s)
uncons Vector Whitespace
ws))
  {-# INLINE _Cons #-}

instance AsEmpty WS where
  _Empty :: p () (f ()) -> p WS (f WS)
_Empty = WS -> (WS -> Bool) -> Prism' WS ()
forall a. a -> (a -> Bool) -> Prism' a ()
nearly WS
forall a. Monoid a => a
mempty (WS -> Getting Bool WS Bool -> Bool
forall s a. s -> Getting a s a -> a
^. (Vector Whitespace -> Const Bool (Vector Whitespace))
-> WS -> Const Bool WS
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped ((Vector Whitespace -> Const Bool (Vector Whitespace))
 -> WS -> Const Bool WS)
-> ((Bool -> Const Bool Bool)
    -> Vector Whitespace -> Const Bool (Vector Whitespace))
-> Getting Bool WS Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Whitespace -> Bool)
-> (Bool -> Const Bool Bool)
-> Vector Whitespace
-> Const Bool (Vector Whitespace)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (APrism (Vector Whitespace) (Vector Whitespace) () ()
-> Vector Whitespace -> Bool
forall s t a b. APrism s t a b -> s -> Bool
is APrism (Vector Whitespace) (Vector Whitespace) () ()
forall a. AsEmpty a => Prism' a ()
_Empty))
  {-# INLINE _Empty #-}

instance WS ~ t => Rewrapped WS t
instance Wrapped WS where
  type Unwrapped WS = Vector Whitespace
  _Wrapped' :: p (Unwrapped WS) (f (Unwrapped WS)) -> p WS (f WS)
_Wrapped' = (WS -> Vector Whitespace)
-> (Vector Whitespace -> WS)
-> Iso WS WS (Vector Whitespace) (Vector Whitespace)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(WS Vector Whitespace
x) -> Vector Whitespace
x) Vector Whitespace -> WS
WS
  {-# INLINE _Wrapped' #-}

instance Semigroup WS where
  (WS Vector Whitespace
a) <> :: WS -> WS -> WS
<> (WS Vector Whitespace
b) = Vector Whitespace -> WS
WS (Vector Whitespace
a Vector Whitespace -> Vector Whitespace -> Vector Whitespace
forall a. Semigroup a => a -> a -> a
<> Vector Whitespace
b)
  {-# INLINE (<>) #-}

instance Monoid WS where
  mempty :: WS
mempty = Vector Whitespace -> WS
WS Vector Whitespace
forall a. Vector a
V.empty
  {-# INLINE mempty #-}
  mappend :: WS -> WS -> WS
mappend = WS -> WS -> WS
forall a. Semigroup a => a -> a -> a
(<>)
  {-# INLINE mappend #-}

-- | Handy 'Prism'' between a 'Char' its possible 'Whitespace' representation.
_WhitespaceChar :: Prism' Char Whitespace
_WhitespaceChar :: p Whitespace (f Whitespace) -> p Char (f Char)
_WhitespaceChar = (Whitespace -> Char)
-> (Char -> Either Char Whitespace)
-> Prism Char Char Whitespace Whitespace
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism Whitespace -> Char
escapedWhitespaceChar
  (\Char
x -> case Char
x of
      Char
' '  -> Whitespace -> Either Char Whitespace
forall a b. b -> Either a b
Right Whitespace
Space
      Char
'\t' -> Whitespace -> Either Char Whitespace
forall a b. b -> Either a b
Right Whitespace
HorizontalTab
      Char
'\f' -> Whitespace -> Either Char Whitespace
forall a b. b -> Either a b
Right Whitespace
LineFeed
      Char
'\r' -> Whitespace -> Either Char Whitespace
forall a b. b -> Either a b
Right Whitespace
CarriageReturn
      Char
'\n' -> Whitespace -> Either Char Whitespace
forall a b. b -> Either a b
Right Whitespace
NewLine
      Char
_    -> Char -> Either Char Whitespace
forall a b. a -> Either a b
Left Char
x
      )

-- | Parse a single 'Whitespace' character.
oneWhitespace
  :: CharParsing f
  => f Whitespace
oneWhitespace :: f Whitespace
oneWhitespace = [f Whitespace] -> f Whitespace
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
  [ Whitespace
Space          Whitespace -> f Char -> f Whitespace
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> f Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
' '
  , Whitespace
HorizontalTab  Whitespace -> f Char -> f Whitespace
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f Char
forall (m :: * -> *). CharParsing m => m Char
tab
  , Whitespace
LineFeed       Whitespace -> f Char -> f Whitespace
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> f Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'\f'
  , Whitespace
CarriageReturn Whitespace -> f Char -> f Whitespace
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> f Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'\r'
  , Whitespace
NewLine        Whitespace -> f Char -> f Whitespace
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f Char
forall (m :: * -> *). CharParsing m => m Char
newline
  ]

-- |
--
-- >>> testparse parseWhitespace " "
-- Right (WS [Space])
--
-- >>> testparse parseWhitespace "\n    "
-- Right (WS [NewLine,Space,Space,Space,Space])
--
-- >>> testparse parseWhitespace " \t"
-- Right (WS [Space,HorizontalTab])
--
-- >>> testparse parseWhitespace "\f\f"
-- Right (WS [LineFeed,LineFeed])
--
-- >>> testparse parseWhitespace "\r\r\r"
-- Right (WS [CarriageReturn,CarriageReturn,CarriageReturn])
--
-- >>> testparse parseWhitespace "\n\r\r\n"
-- Right (WS [NewLine,CarriageReturn,CarriageReturn,NewLine])
--
-- >>> testparse parseWhitespace ""
-- Right (WS [])
--
-- >>> testparse parseWhitespace "\n   ]"
-- Right (WS [NewLine,Space,Space,Space])
--
parseWhitespace
  :: CharParsing f
  => f WS
parseWhitespace :: f WS
parseWhitespace =
  Vector Whitespace -> WS
WS (Vector Whitespace -> WS)
-> ([Whitespace] -> Vector Whitespace) -> [Whitespace] -> WS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Whitespace] -> Vector Whitespace
forall a. [a] -> Vector a
V.fromList ([Whitespace] -> WS) -> f [Whitespace] -> f WS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Whitespace -> f [Whitespace]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many f Whitespace
forall (f :: * -> *). CharParsing f => f Whitespace
oneWhitespace

-- | Parse a 'NonEmpty' sequence of consecutive whitespace.
parseSomeWhitespace
  :: CharParsing f
  => f (NonEmpty Whitespace)
parseSomeWhitespace :: f (NonEmpty Whitespace)
parseSomeWhitespace =
  (Whitespace -> [Whitespace] -> NonEmpty Whitespace)
-> f Whitespace -> f [Whitespace] -> f (NonEmpty Whitespace)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Whitespace -> [Whitespace] -> NonEmpty Whitespace
forall a. a -> [a] -> NonEmpty a
(:|) f Whitespace
forall (f :: * -> *). CharParsing f => f Whitespace
oneWhitespace (f Whitespace -> f [Whitespace]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many f Whitespace
forall (f :: * -> *). CharParsing f => f Whitespace
oneWhitespace)

-- | Change a 'Whitespace' into a single unescaped 'Char'. Useful if you're
-- already handling escaping with some other mechanism.
unescapedWhitespaceChar :: Whitespace -> Char
unescapedWhitespaceChar :: Whitespace -> Char
unescapedWhitespaceChar Whitespace
Space          = Char
' '
unescapedWhitespaceChar Whitespace
HorizontalTab  = Char
't'
unescapedWhitespaceChar Whitespace
LineFeed       = Char
'f'
unescapedWhitespaceChar Whitespace
CarriageReturn = Char
'r'
unescapedWhitespaceChar Whitespace
NewLine        = Char
'n'
{-# INLINE unescapedWhitespaceChar #-}

-- | Change a 'Whitespace' into its escaped 'Char' form.
escapedWhitespaceChar :: Whitespace -> Char
escapedWhitespaceChar :: Whitespace -> Char
escapedWhitespaceChar Whitespace
Space          = Char
' '
escapedWhitespaceChar Whitespace
HorizontalTab  = Char
'\t'
escapedWhitespaceChar Whitespace
LineFeed       = Char
'\f'
escapedWhitespaceChar Whitespace
CarriageReturn = Char
'\r'
escapedWhitespaceChar Whitespace
NewLine        = Char
'\n'
{-# INLINE escapedWhitespaceChar #-}