{-# OPTIONS_GHC -Wall -Werror #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

#undef MEGAPARSEC_7_OR_LATER
#ifdef MIN_VERSION_GLASGOW_HASKELL
-- GHC >= 7.10.1.0
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
-- GHC >= 8.0.0.0
#if MIN_VERSION_megaparsec(7,0,0)
#define MEGAPARSEC_7_OR_LATER
#endif
#endif
#endif

module Text.SExpression.Default
  ( LiteralParsers(..)
  , LiteralParsersM
  , mkLiteralParsers
  , overrideStringP
  , overrideNumberP
  , overrideBoolP
  , parseStringDef
  , parseNumberDef
  , parseBoolDef
  ) where

import Data.Maybe (fromJust)
import Data.Semigroup (Last(..))
import Data.Default
import Text.SExpression.Types (SExpr(..), Parser)
import Control.Monad (void)
import Text.Megaparsec
    ( (<|>)
    , many
    , notFollowedBy
#ifdef MEGAPARSEC_7_OR_LATER
    , noneOf
#endif
    , some
    )
import Text.Megaparsec.Char
    ( char
    , digitChar
    , string
    , alphaNumChar
#ifndef MEGAPARSEC_7_OR_LATER
    , noneOf
#endif
    )

-- | Partial parser configuration
data LiteralParsersM = LiteralParsersM
  { LiteralParsersM -> Maybe (Last (Parser SExpr))
parseStringM :: Maybe (Last (Parser SExpr))
  , LiteralParsersM -> Maybe (Last (Parser SExpr))
parseNumberM :: Maybe (Last (Parser SExpr))
  , LiteralParsersM -> Maybe (Last (Parser SExpr))
parseBoolM   :: Maybe (Last (Parser SExpr))
  }

-- | Fully defined parser configuration
data LiteralParsers = LiteralParsers
  { LiteralParsers -> Parser SExpr
parseString :: Parser SExpr
  , LiteralParsers -> Parser SExpr
parseNumber :: Parser SExpr
  , LiteralParsers -> Parser SExpr
parseBool   :: Parser SExpr
  }

instance Semigroup LiteralParsersM where
  <> :: LiteralParsersM -> LiteralParsersM -> LiteralParsersM
(<>)
    (LiteralParsersM Maybe (Last (Parser SExpr))
ps Maybe (Last (Parser SExpr))
pn Maybe (Last (Parser SExpr))
pb)
    (LiteralParsersM Maybe (Last (Parser SExpr))
ps' Maybe (Last (Parser SExpr))
pn' Maybe (Last (Parser SExpr))
pb') =
    Maybe (Last (Parser SExpr))
-> Maybe (Last (Parser SExpr))
-> Maybe (Last (Parser SExpr))
-> LiteralParsersM
LiteralParsersM (Maybe (Last (Parser SExpr))
ps Maybe (Last (Parser SExpr))
-> Maybe (Last (Parser SExpr)) -> Maybe (Last (Parser SExpr))
forall a. Semigroup a => a -> a -> a
<> Maybe (Last (Parser SExpr))
ps') (Maybe (Last (Parser SExpr))
pn Maybe (Last (Parser SExpr))
-> Maybe (Last (Parser SExpr)) -> Maybe (Last (Parser SExpr))
forall a. Semigroup a => a -> a -> a
<> Maybe (Last (Parser SExpr))
pn') (Maybe (Last (Parser SExpr))
pb Maybe (Last (Parser SExpr))
-> Maybe (Last (Parser SExpr)) -> Maybe (Last (Parser SExpr))
forall a. Semigroup a => a -> a -> a
<> Maybe (Last (Parser SExpr))
pb')

instance Default LiteralParsersM where
  def :: LiteralParsersM
def = LiteralParsersM :: Maybe (Last (Parser SExpr))
-> Maybe (Last (Parser SExpr))
-> Maybe (Last (Parser SExpr))
-> LiteralParsersM
LiteralParsersM
        { parseStringM :: Maybe (Last (Parser SExpr))
parseStringM = Last (Parser SExpr) -> Maybe (Last (Parser SExpr))
forall a. a -> Maybe a
Just (Last (Parser SExpr) -> Maybe (Last (Parser SExpr)))
-> Last (Parser SExpr) -> Maybe (Last (Parser SExpr))
forall a b. (a -> b) -> a -> b
$ Parser SExpr -> Last (Parser SExpr)
forall a. a -> Last a
Last Parser SExpr
parseStringDef
        , parseNumberM :: Maybe (Last (Parser SExpr))
parseNumberM = Last (Parser SExpr) -> Maybe (Last (Parser SExpr))
forall a. a -> Maybe a
Just (Last (Parser SExpr) -> Maybe (Last (Parser SExpr)))
-> Last (Parser SExpr) -> Maybe (Last (Parser SExpr))
forall a b. (a -> b) -> a -> b
$ Parser SExpr -> Last (Parser SExpr)
forall a. a -> Last a
Last Parser SExpr
parseNumberDef
        , parseBoolM :: Maybe (Last (Parser SExpr))
parseBoolM   = Last (Parser SExpr) -> Maybe (Last (Parser SExpr))
forall a. a -> Maybe a
Just (Last (Parser SExpr) -> Maybe (Last (Parser SExpr)))
-> Last (Parser SExpr) -> Maybe (Last (Parser SExpr))
forall a b. (a -> b) -> a -> b
$ Parser SExpr -> Last (Parser SExpr)
forall a. a -> Last a
Last Parser SExpr
parseBoolDef
        }

instance Default LiteralParsers where
  def :: LiteralParsers
def = (LiteralParsersM -> LiteralParsersM) -> LiteralParsers
mkLiteralParsers LiteralParsersM -> LiteralParsersM
forall a. Default a => a
def

-- | Smart constructor for parser configuration
--   that allows overriding the default literal parsers
mkLiteralParsers ::
     (LiteralParsersM -> LiteralParsersM) -- ^ Cumulative override function
  -> LiteralParsers
mkLiteralParsers :: (LiteralParsersM -> LiteralParsersM) -> LiteralParsers
mkLiteralParsers LiteralParsersM -> LiteralParsersM
f =
  case LiteralParsersM -> LiteralParsersM
f LiteralParsersM
forall a. Default a => a
def of
    LiteralParsersM{Maybe (Last (Parser SExpr))
parseBoolM :: Maybe (Last (Parser SExpr))
parseNumberM :: Maybe (Last (Parser SExpr))
parseStringM :: Maybe (Last (Parser SExpr))
parseBoolM :: LiteralParsersM -> Maybe (Last (Parser SExpr))
parseNumberM :: LiteralParsersM -> Maybe (Last (Parser SExpr))
parseStringM :: LiteralParsersM -> Maybe (Last (Parser SExpr))
..} ->
      let Last Parser SExpr
parseString = Maybe (Last (Parser SExpr)) -> Last (Parser SExpr)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Last (Parser SExpr))
parseStringM
          Last Parser SExpr
parseNumber = Maybe (Last (Parser SExpr)) -> Last (Parser SExpr)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Last (Parser SExpr))
parseNumberM
          Last Parser SExpr
parseBool   = Maybe (Last (Parser SExpr)) -> Last (Parser SExpr)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Last (Parser SExpr))
parseBoolM in
        Parser SExpr -> Parser SExpr -> Parser SExpr -> LiteralParsers
LiteralParsers Parser SExpr
parseString Parser SExpr
parseNumber Parser SExpr
parseBool

-- | String parser override function
overrideStringP :: Parser SExpr -- ^ String parser
  -> (LiteralParsersM ->  LiteralParsersM)
overrideStringP :: Parser SExpr -> LiteralParsersM -> LiteralParsersM
overrideStringP Parser SExpr
sp LiteralParsersM
lp = LiteralParsersM
lp LiteralParsersM -> LiteralParsersM -> LiteralParsersM
forall a. Semigroup a => a -> a -> a
<>
  LiteralParsersM :: Maybe (Last (Parser SExpr))
-> Maybe (Last (Parser SExpr))
-> Maybe (Last (Parser SExpr))
-> LiteralParsersM
LiteralParsersM
  { parseStringM :: Maybe (Last (Parser SExpr))
parseStringM = Last (Parser SExpr) -> Maybe (Last (Parser SExpr))
forall a. a -> Maybe a
Just (Last (Parser SExpr) -> Maybe (Last (Parser SExpr)))
-> Last (Parser SExpr) -> Maybe (Last (Parser SExpr))
forall a b. (a -> b) -> a -> b
$ Parser SExpr -> Last (Parser SExpr)
forall a. a -> Last a
Last Parser SExpr
sp
  , parseNumberM :: Maybe (Last (Parser SExpr))
parseNumberM = Maybe (Last (Parser SExpr))
forall a. Maybe a
Nothing
  , parseBoolM :: Maybe (Last (Parser SExpr))
parseBoolM   = Maybe (Last (Parser SExpr))
forall a. Maybe a
Nothing
  }

-- | Number parser override function
overrideNumberP :: Parser SExpr -- ^ Number parser
  -> (LiteralParsersM ->  LiteralParsersM)
overrideNumberP :: Parser SExpr -> LiteralParsersM -> LiteralParsersM
overrideNumberP Parser SExpr
np LiteralParsersM
lp = LiteralParsersM
lp LiteralParsersM -> LiteralParsersM -> LiteralParsersM
forall a. Semigroup a => a -> a -> a
<>
  LiteralParsersM :: Maybe (Last (Parser SExpr))
-> Maybe (Last (Parser SExpr))
-> Maybe (Last (Parser SExpr))
-> LiteralParsersM
LiteralParsersM
  { parseStringM :: Maybe (Last (Parser SExpr))
parseStringM = Maybe (Last (Parser SExpr))
forall a. Maybe a
Nothing
  , parseNumberM :: Maybe (Last (Parser SExpr))
parseNumberM = Last (Parser SExpr) -> Maybe (Last (Parser SExpr))
forall a. a -> Maybe a
Just (Last (Parser SExpr) -> Maybe (Last (Parser SExpr)))
-> Last (Parser SExpr) -> Maybe (Last (Parser SExpr))
forall a b. (a -> b) -> a -> b
$ Parser SExpr -> Last (Parser SExpr)
forall a. a -> Last a
Last Parser SExpr
np
  , parseBoolM :: Maybe (Last (Parser SExpr))
parseBoolM   = Maybe (Last (Parser SExpr))
forall a. Maybe a
Nothing
  }

-- | Boolean parser override function
overrideBoolP :: Parser SExpr -- ^ Bool parser
  -> (LiteralParsersM ->  LiteralParsersM)
overrideBoolP :: Parser SExpr -> LiteralParsersM -> LiteralParsersM
overrideBoolP Parser SExpr
bp LiteralParsersM
lp = LiteralParsersM
lp LiteralParsersM -> LiteralParsersM -> LiteralParsersM
forall a. Semigroup a => a -> a -> a
<>
  LiteralParsersM :: Maybe (Last (Parser SExpr))
-> Maybe (Last (Parser SExpr))
-> Maybe (Last (Parser SExpr))
-> LiteralParsersM
LiteralParsersM
  { parseStringM :: Maybe (Last (Parser SExpr))
parseStringM = Maybe (Last (Parser SExpr))
forall a. Maybe a
Nothing
  , parseNumberM :: Maybe (Last (Parser SExpr))
parseNumberM = Maybe (Last (Parser SExpr))
forall a. Maybe a
Nothing
  , parseBoolM :: Maybe (Last (Parser SExpr))
parseBoolM   = Last (Parser SExpr) -> Maybe (Last (Parser SExpr))
forall a. a -> Maybe a
Just (Last (Parser SExpr) -> Maybe (Last (Parser SExpr)))
-> Last (Parser SExpr) -> Maybe (Last (Parser SExpr))
forall a b. (a -> b) -> a -> b
$ Parser SExpr -> Last (Parser SExpr)
forall a. a -> Last a
Last Parser SExpr
bp
  }
  
-- | Default parser for s-expression boolean literals
parseBoolDef ::
  Parser SExpr
parseBoolDef :: Parser SExpr
parseBoolDef = do
  [Char]
b <-  Tokens [Char] -> ParsecT Void [Char] Identity (Tokens [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string [Char]
Tokens [Char]
"#t" ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity ()
-> ParsecT Void [Char] Identity [Char]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void [Char] Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
    ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity [Char]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens [Char] -> ParsecT Void [Char] Identity (Tokens [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string [Char]
Tokens [Char]
"#f" ParsecT Void [Char] Identity [Char]
-> ParsecT Void [Char] Identity ()
-> ParsecT Void [Char] Identity [Char]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void [Char] Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
  case [Char]
b of
    [Char]
"#t" -> SExpr -> Parser SExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr -> Parser SExpr) -> SExpr -> Parser SExpr
forall a b. (a -> b) -> a -> b
$ Bool -> SExpr
Bool Bool
True
    [Char]
"#f" -> SExpr -> Parser SExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr -> Parser SExpr) -> SExpr -> Parser SExpr
forall a b. (a -> b) -> a -> b
$ Bool -> SExpr
Bool Bool
False
    [Char]
_ -> [Char] -> Parser SExpr
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Not a boolean"
  
-- | Default parser for s-expression numeric literals
parseNumberDef ::
    Parser SExpr    -- ^ parser
parseNumberDef :: Parser SExpr
parseNumberDef = (Integer -> SExpr
Number (Integer -> SExpr) -> ([Char] -> Integer) -> [Char] -> SExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Integer
forall a. Read a => [Char] -> a
read) ([Char] -> SExpr)
-> ParsecT Void [Char] Identity [Char] -> Parser SExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void [Char] Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar

-- | Default parser for s-expression string literals
parseStringDef ::
    Parser SExpr    -- ^ parser
parseStringDef :: Parser SExpr
parseStringDef = do
    ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void [Char] Identity Char
 -> ParsecT Void [Char] Identity ())
-> ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity ()
forall a b. (a -> b) -> a -> b
$ Token [Char] -> ParsecT Void [Char] Identity (Token [Char])
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token [Char]
'"'
    [Char]
s <- ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ([Token [Char]] -> ParsecT Void [Char] Identity (Token [Char])
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf [Char]
[Token [Char]]
"\"")
    ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void [Char] Identity Char
 -> ParsecT Void [Char] Identity ())
-> ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity ()
forall a b. (a -> b) -> a -> b
$ Token [Char] -> ParsecT Void [Char] Identity (Token [Char])
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token [Char]
'"'
    SExpr -> Parser SExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SExpr -> Parser SExpr) -> SExpr -> Parser SExpr
forall a b. (a -> b) -> a -> b
$ [Char] -> SExpr
String [Char]
s