{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Database.Persist.Quasi.Internal.ModelParser
    ( SourceLoc (..)
    , Attribute (..)
    , attribute
    , attributeContent
    , Directive (..)
    , directiveContent
    , EntityField (..)
    , entityField
    , entityFieldContent
    , FieldName (..)
    , fieldName
    , ParsedEntityDef (..)
    , parseSource
    , memberEntityFields
    , ParserWarning
    , parserWarningMessage
    , ParseResult
    , CumulativeParseResult
    , toCumulativeParseResult
    , renderErrors
    , runConfiguredParser
    , ParserErrorLevel (..)
    , initialExtraState
    ) where

import Control.Applicative (Alternative)
import Control.Monad (MonadPlus, void)
import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT)
import Control.Monad.State
import Control.Monad.Writer
import Data.Char (isSpace)
import Data.Either (partitionEithers)
import Data.Foldable (fold)
import Data.Functor.Identity
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Void
import Database.Persist.Quasi.Internal.TypeParser
import Database.Persist.Quasi.PersistSettings.Internal
import Database.Persist.Types
import Database.Persist.Types.SourceSpan
import Language.Haskell.TH.Syntax (Lift)
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import qualified Text.Megaparsec.Stream as TMS

-- We'll augment the parser with extra state to accumulate comments seen during parsing.
-- Comments are lexed as whitespace, but will be used to generate documentation later.
data ExtraState = ExtraState
    { ExtraState -> [(SourcePos, CommentToken)]
esPositionedCommentTokens :: [(SourcePos, CommentToken)]
    , ExtraState -> Maybe SourcePos
esLastDocumentablePosition :: Maybe SourcePos
    }

-- @since 2.16.0.0
initialExtraState :: ExtraState
initialExtraState :: ExtraState
initialExtraState =
    ExtraState
        { esPositionedCommentTokens :: [(SourcePos, CommentToken)]
esPositionedCommentTokens = []
        , esLastDocumentablePosition :: Maybe SourcePos
esLastDocumentablePosition = Maybe SourcePos
forall a. Maybe a
Nothing
        }

newtype Parser a = Parser
    { forall a.
Parser a
-> ReaderT
     PersistSettings
     (StateT
        ExtraState (ParsecT Void String (Writer (Set ParserWarning))))
     a
unParser
        :: ReaderT
            PersistSettings
            ( StateT
                ExtraState
                ( ParsecT
                    Void
                    String
                    ( Writer
                        (Set ParserWarning)
                    )
                )
            )
            a
    }
    deriving newtype
        ( (forall a b. (a -> b) -> Parser a -> Parser b)
-> (forall a b. a -> Parser b -> Parser a) -> Functor Parser
forall a b. a -> Parser b -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Parser a -> Parser b
fmap :: forall a b. (a -> b) -> Parser a -> Parser b
$c<$ :: forall a b. a -> Parser b -> Parser a
<$ :: forall a b. a -> Parser b -> Parser a
Functor
        , Functor Parser
Functor Parser =>
(forall a. a -> Parser a)
-> (forall a b. Parser (a -> b) -> Parser a -> Parser b)
-> (forall a b c.
    (a -> b -> c) -> Parser a -> Parser b -> Parser c)
-> (forall a b. Parser a -> Parser b -> Parser b)
-> (forall a b. Parser a -> Parser b -> Parser a)
-> Applicative Parser
forall a. a -> Parser a
forall a b. Parser a -> Parser b -> Parser a
forall a b. Parser a -> Parser b -> Parser b
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Parser a
pure :: forall a. a -> Parser a
$c<*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
<*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
$cliftA2 :: forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
liftA2 :: forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
$c*> :: forall a b. Parser a -> Parser b -> Parser b
*> :: forall a b. Parser a -> Parser b -> Parser b
$c<* :: forall a b. Parser a -> Parser b -> Parser a
<* :: forall a b. Parser a -> Parser b -> Parser a
Applicative
        , Applicative Parser
Applicative Parser =>
(forall a b. Parser a -> (a -> Parser b) -> Parser b)
-> (forall a b. Parser a -> Parser b -> Parser b)
-> (forall a. a -> Parser a)
-> Monad Parser
forall a. a -> Parser a
forall a b. Parser a -> Parser b -> Parser b
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
>>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
$c>> :: forall a b. Parser a -> Parser b -> Parser b
>> :: forall a b. Parser a -> Parser b -> Parser b
$creturn :: forall a. a -> Parser a
return :: forall a. a -> Parser a
Monad
        , Applicative Parser
Applicative Parser =>
(forall a. Parser a)
-> (forall a. Parser a -> Parser a -> Parser a)
-> (forall a. Parser a -> Parser [a])
-> (forall a. Parser a -> Parser [a])
-> Alternative Parser
forall a. Parser a
forall a. Parser a -> Parser [a]
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall a. Parser a
empty :: forall a. Parser a
$c<|> :: forall a. Parser a -> Parser a -> Parser a
<|> :: forall a. Parser a -> Parser a -> Parser a
$csome :: forall a. Parser a -> Parser [a]
some :: forall a. Parser a -> Parser [a]
$cmany :: forall a. Parser a -> Parser [a]
many :: forall a. Parser a -> Parser [a]
Alternative
        , Monad Parser
Alternative Parser
(Alternative Parser, Monad Parser) =>
(forall a. Parser a)
-> (forall a. Parser a -> Parser a -> Parser a) -> MonadPlus Parser
forall a. Parser a
forall a. Parser a -> Parser a -> Parser a
forall (m :: * -> *).
(Alternative m, Monad m) =>
(forall a. m a) -> (forall a. m a -> m a -> m a) -> MonadPlus m
$cmzero :: forall a. Parser a
mzero :: forall a. Parser a
$cmplus :: forall a. Parser a -> Parser a -> Parser a
mplus :: forall a. Parser a -> Parser a -> Parser a
MonadPlus
        , MonadState ExtraState
        , MonadReader PersistSettings
        , MonadParsec Void String
        , Monad Parser
Monad Parser => (forall a. String -> Parser a) -> MonadFail Parser
forall a. String -> Parser a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall a. String -> Parser a
fail :: forall a. String -> Parser a
MonadFail
        )

type EntityParseError = ParseErrorBundle String Void

-- | Result of parsing a single source text.
--
-- @since 2.16.0.0
type ParseResult a =
    (Set ParserWarning, Either (ParseErrorBundle String Void) a)

type InternalParseResult a = ParseResult (a, ExtraState)

-- | Cumulative result of parsing multiple source texts.
--
-- @since 2.16.0.0
type CumulativeParseResult a = (Set ParserWarning, Either [EntityParseError] a)

toCumulativeParseResult
    :: (Monoid a) => [ParseResult a] -> CumulativeParseResult a
toCumulativeParseResult :: forall a. Monoid a => [ParseResult a] -> CumulativeParseResult a
toCumulativeParseResult [ParseResult a]
prs = do
    let
        (Set ParserWarning
warnings, [Either (ParseErrorBundle String Void) a]
eithers) = [ParseResult a]
-> (Set ParserWarning, [Either (ParseErrorBundle String Void) a])
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ParseResult a]
prs
    case [Either (ParseErrorBundle String Void) a]
-> ([ParseErrorBundle String Void], [a])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (ParseErrorBundle String Void) a]
eithers of
        ([], [a]
results) -> (Set ParserWarning
warnings, a -> Either [ParseErrorBundle String Void] a
forall a b. b -> Either a b
Right (a -> Either [ParseErrorBundle String Void] a)
-> a -> Either [ParseErrorBundle String Void] a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [a]
results)
        ([ParseErrorBundle String Void]
errs, [a]
_) -> (Set ParserWarning
warnings, [ParseErrorBundle String Void]
-> Either [ParseErrorBundle String Void] a
forall a b. a -> Either a b
Left [ParseErrorBundle String Void]
errs)

-- | Run a parser using provided PersistSettings and ExtraState
-- @since 2.16.0.0
runConfiguredParser
    :: PersistSettings
    -> ExtraState
    -> Parser a
    -> String
    -> String
    -> InternalParseResult a
runConfiguredParser :: forall a.
PersistSettings
-> ExtraState
-> Parser a
-> String
-> String
-> InternalParseResult a
runConfiguredParser PersistSettings
ps ExtraState
acc Parser a
parser String
fp String
s = (Set ParserWarning
warnings, Either (ParseErrorBundle String Void) (a, ExtraState)
either)
  where
    sm :: StateT
  ExtraState (ParsecT Void String (Writer (Set ParserWarning))) a
sm = ReaderT
  PersistSettings
  (StateT
     ExtraState (ParsecT Void String (Writer (Set ParserWarning))))
  a
-> PersistSettings
-> StateT
     ExtraState (ParsecT Void String (Writer (Set ParserWarning))) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Parser a
-> ReaderT
     PersistSettings
     (StateT
        ExtraState (ParsecT Void String (Writer (Set ParserWarning))))
     a
forall a.
Parser a
-> ReaderT
     PersistSettings
     (StateT
        ExtraState (ParsecT Void String (Writer (Set ParserWarning))))
     a
unParser Parser a
parser) PersistSettings
ps
    pm :: ParsecT Void String (Writer (Set ParserWarning)) (a, ExtraState)
pm = StateT
  ExtraState (ParsecT Void String (Writer (Set ParserWarning))) a
-> ExtraState
-> ParsecT Void String (Writer (Set ParserWarning)) (a, ExtraState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT
  ExtraState (ParsecT Void String (Writer (Set ParserWarning))) a
sm ExtraState
acc
    wm :: Writer
  (Set ParserWarning)
  (State String Void,
   Either (ParseErrorBundle String Void) (a, ExtraState))
wm = ParsecT Void String (Writer (Set ParserWarning)) (a, ExtraState)
-> State String Void
-> Writer
     (Set ParserWarning)
     (State String Void,
      Either (ParseErrorBundle String Void) (a, ExtraState))
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> State s e -> m (State s e, Either (ParseErrorBundle s e) a)
runParserT' ParsecT Void String (Writer (Set ParserWarning)) (a, ExtraState)
pm State String Void
initialInternalState
    ((State String Void
_is, Either (ParseErrorBundle String Void) (a, ExtraState)
either), Set ParserWarning
warnings) = Writer
  (Set ParserWarning)
  (State String Void,
   Either (ParseErrorBundle String Void) (a, ExtraState))
-> ((State String Void,
     Either (ParseErrorBundle String Void) (a, ExtraState)),
    Set ParserWarning)
forall w a. Writer w a -> (a, w)
runWriter Writer
  (Set ParserWarning)
  (State String Void,
   Either (ParseErrorBundle String Void) (a, ExtraState))
wm

    initialSourcePos :: SourcePos
initialSourcePos =
        SourcePos
            { sourceName :: String
sourceName = String
fp
            , sourceLine :: Pos
sourceLine = Pos
pos1
            , sourceColumn :: Pos
sourceColumn = Pos
pos1
            }
    initialPosState :: PosState String
initialPosState =
        PosState
            { pstateInput :: String
pstateInput = String
s
            , pstateOffset :: Int
pstateOffset = Int
0
            , pstateSourcePos :: SourcePos
pstateSourcePos = SourcePos
initialSourcePos
            , -- for legacy compatibility, we treat each tab as a single unit of whitespace
              pstateTabWidth :: Pos
pstateTabWidth = Pos
pos1
            , pstateLinePrefix :: String
pstateLinePrefix = String
""
            }
    initialInternalState :: State String Void
initialInternalState =
        State
            { stateInput :: String
stateInput = String
s
            , stateOffset :: Int
stateOffset = Int
0
            , statePosState :: PosState String
statePosState = PosState String
initialPosState
            , stateParseErrors :: [ParseError String Void]
stateParseErrors = []
            }

reportWarnings :: Set ParserWarning -> Parser ()
#if MIN_VERSION_megaparsec(9,5,0)
reportWarnings :: Set ParserWarning -> Parser ()
reportWarnings = ReaderT
  PersistSettings
  (StateT
     ExtraState (ParsecT Void String (Writer (Set ParserWarning))))
  ()
-> Parser ()
forall a.
ReaderT
  PersistSettings
  (StateT
     ExtraState (ParsecT Void String (Writer (Set ParserWarning))))
  a
-> Parser a
Parser (ReaderT
   PersistSettings
   (StateT
      ExtraState (ParsecT Void String (Writer (Set ParserWarning))))
   ()
 -> Parser ())
-> (Set ParserWarning
    -> ReaderT
         PersistSettings
         (StateT
            ExtraState (ParsecT Void String (Writer (Set ParserWarning))))
         ())
-> Set ParserWarning
-> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ParserWarning
-> ReaderT
     PersistSettings
     (StateT
        ExtraState (ParsecT Void String (Writer (Set ParserWarning))))
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
#else
reportWarnings _pw = pure ()
#endif

-- | Renders a list of EntityParseErrors as a String using `errorBundlePretty`,
-- separated by line breaks.
-- @since 2.16.0.0
renderErrors :: [EntityParseError] -> String
renderErrors :: [ParseErrorBundle String Void] -> String
renderErrors [ParseErrorBundle String Void]
errs = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (ParseErrorBundle String Void -> String)
-> [ParseErrorBundle String Void] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty [ParseErrorBundle String Void]
errs

-- | Attempts to parse with a provided parser. If it fails with an error matching
-- the provided predicate, it registers a warning with the provided message and falls
-- back to the second provided parser.
tryOrWarn
    :: String
    -> (ParseError String Void -> Bool)
    -> Parser a
    -> Parser a
    -> Parser a
tryOrWarn :: forall a.
String
-> (ParseError String Void -> Bool)
-> Parser a
-> Parser a
-> Parser a
tryOrWarn String
msg ParseError String Void -> Bool
p Parser a
l Parser a
r = do
    State String Void
parserState <- Parser (State String Void)
forall e s (m :: * -> *). MonadParsec e s m => m (State s e)
getParserState
    (ParseError String Void -> Parser a) -> Parser a -> Parser a
forall a.
(ParseError String Void -> Parser a) -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(ParseError s e -> m a) -> m a -> m a
withRecovery (PosState String -> ParseError String Void -> Parser a
warnAndRetry (PosState String -> ParseError String Void -> Parser a)
-> PosState String -> ParseError String Void -> Parser a
forall a b. (a -> b) -> a -> b
$ State String Void -> PosState String
forall s e. State s e -> PosState s
statePosState State String Void
parserState) Parser a
l
  where
    warnAndRetry :: PosState String -> ParseError String Void -> Parser a
warnAndRetry PosState String
posState ParseError String Void
err = do
        if ParseError String Void -> Bool
p ParseError String Void
err
            then do
                let
                    ([(ParseError String Void, SourcePos)]
pairs, PosState String
_) = (ParseError String Void -> Int)
-> [ParseError String Void]
-> PosState String
-> ([(ParseError String Void, SourcePos)], PosState String)
forall (t :: * -> *) s a.
(Traversable t, TraversableStream s) =>
(a -> Int) -> t a -> PosState s -> (t (a, SourcePos), PosState s)
attachSourcePos ParseError String Void -> Int
forall s e. ParseError s e -> Int
errorOffset [ParseError String Void
err] PosState String
posState
                Set ParserWarning -> Parser ()
reportWarnings (Set ParserWarning -> Parser ())
-> ([ParserWarning] -> Set ParserWarning)
-> [ParserWarning]
-> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParserWarning] -> Set ParserWarning
forall a. Ord a => [a] -> Set a
Set.fromList ([ParserWarning] -> Parser ()) -> [ParserWarning] -> Parser ()
forall a b. (a -> b) -> a -> b
$
                    ((ParseError String Void, SourcePos) -> ParserWarning)
-> [(ParseError String Void, SourcePos)] -> [ParserWarning]
forall a b. (a -> b) -> [a] -> [b]
map
                        ( \(ParseError String Void
e, SourcePos
_pos) ->
                            ParserWarning
                                { parserWarningExtraMessage :: String
parserWarningExtraMessage = String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                                , parserWarningUnderlyingError :: ParseError String Void
parserWarningUnderlyingError = ParseError String Void
e
                                , parserWarningPosState :: PosState String
parserWarningPosState = PosState String
posState
                                }
                        )
                        [(ParseError String Void, SourcePos)]
pairs
                Parser a
r
            else ParseError String Void -> Parser a
forall a. ParseError String Void -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ParseError s e -> m a
parseError ParseError String Void
err

-- | Attempts to parse with a provided parser. If it fails with an error matching
-- the provided predicate, it registers a delayed error and falls
-- back to the second provided parser.
--
-- This is useful when registering errors in space consumers and other parsers that are called
-- with `try`, since a non-delayed error in this context will cause backtracking and not
-- get reported to the user.
tryOrRegisterError
    :: (ParseError String Void -> Bool)
    -> Parser a
    -> Parser a
    -> Parser a
tryOrRegisterError :: forall a.
(ParseError String Void -> Bool)
-> Parser a -> Parser a -> Parser a
tryOrRegisterError ParseError String Void -> Bool
p Parser a
l Parser a
r = do
    State String Void
parserState <- Parser (State String Void)
forall e s (m :: * -> *). MonadParsec e s m => m (State s e)
getParserState
    (ParseError String Void -> Parser a) -> Parser a -> Parser a
forall a.
(ParseError String Void -> Parser a) -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(ParseError s e -> m a) -> m a -> m a
withRecovery (PosState String -> ParseError String Void -> Parser a
delayedError (PosState String -> ParseError String Void -> Parser a)
-> PosState String -> ParseError String Void -> Parser a
forall a b. (a -> b) -> a -> b
$ State String Void -> PosState String
forall s e. State s e -> PosState s
statePosState State String Void
parserState) Parser a
l
  where
    delayedError :: PosState String -> ParseError String Void -> Parser a
delayedError PosState String
posState ParseError String Void
err = do
        if ParseError String Void -> Bool
p ParseError String Void
err
            then do
                let
                    ([(ParseError String Void, SourcePos)]
pairs, PosState String
_) = (ParseError String Void -> Int)
-> [ParseError String Void]
-> PosState String
-> ([(ParseError String Void, SourcePos)], PosState String)
forall (t :: * -> *) s a.
(Traversable t, TraversableStream s) =>
(a -> Int) -> t a -> PosState s -> (t (a, SourcePos), PosState s)
attachSourcePos ParseError String Void -> Int
forall s e. ParseError s e -> Int
errorOffset [ParseError String Void
err] PosState String
posState
                ParseError String Void -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
ParseError s e -> m ()
registerParseError ParseError String Void
err
                Parser a
r
            else ParseError String Void -> Parser a
forall a. ParseError String Void -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ParseError s e -> m a
parseError ParseError String Void
err

tryOrReport
    :: Maybe ParserErrorLevel
    -> String
    -> (ParseError String Void -> Bool)
    -> Parser a
    -> Parser a
    -> Parser a
tryOrReport :: forall a.
Maybe ParserErrorLevel
-> String
-> (ParseError String Void -> Bool)
-> Parser a
-> Parser a
-> Parser a
tryOrReport Maybe ParserErrorLevel
level String
msg ParseError String Void -> Bool
p Parser a
l Parser a
r = case Maybe ParserErrorLevel
level of
    Just ParserErrorLevel
LevelError -> (ParseError String Void -> Bool)
-> Parser a -> Parser a -> Parser a
forall a.
(ParseError String Void -> Bool)
-> Parser a -> Parser a -> Parser a
tryOrRegisterError ParseError String Void -> Bool
p Parser a
l Parser a
r
    Just ParserErrorLevel
LevelWarning -> String
-> (ParseError String Void -> Bool)
-> Parser a
-> Parser a
-> Parser a
forall a.
String
-> (ParseError String Void -> Bool)
-> Parser a
-> Parser a
-> Parser a
tryOrWarn String
msg ParseError String Void -> Bool
p Parser a
l Parser a
r
    Maybe ParserErrorLevel
Nothing -> Parser a
r

-- | Source location: file and line/col information. This is half of a 'SourceSpan'.
--
-- @since 2.16.0.0
data SourceLoc = SourceLoc
    { SourceLoc -> Text
locFile :: Text
    , SourceLoc -> Int
locStartLine :: Int
    , SourceLoc -> Int
locStartCol :: Int
    }
    deriving (Int -> SourceLoc -> String -> String
[SourceLoc] -> String -> String
SourceLoc -> String
(Int -> SourceLoc -> String -> String)
-> (SourceLoc -> String)
-> ([SourceLoc] -> String -> String)
-> Show SourceLoc
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SourceLoc -> String -> String
showsPrec :: Int -> SourceLoc -> String -> String
$cshow :: SourceLoc -> String
show :: SourceLoc -> String
$cshowList :: [SourceLoc] -> String -> String
showList :: [SourceLoc] -> String -> String
Show, (forall (m :: * -> *). Quote m => SourceLoc -> m Exp)
-> (forall (m :: * -> *). Quote m => SourceLoc -> Code m SourceLoc)
-> Lift SourceLoc
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => SourceLoc -> m Exp
forall (m :: * -> *). Quote m => SourceLoc -> Code m SourceLoc
$clift :: forall (m :: * -> *). Quote m => SourceLoc -> m Exp
lift :: forall (m :: * -> *). Quote m => SourceLoc -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => SourceLoc -> Code m SourceLoc
liftTyped :: forall (m :: * -> *). Quote m => SourceLoc -> Code m SourceLoc
Lift)

-- | An attribute of an entity field definition or a directive.
--
-- @since 2.17.1.0
data Attribute
    = Assignment Text Text
    | Parenthetical Text
    | PText Text
    | -- | Quoted field attributes are deprecated since 2.17.1.0.
      Quotation Text
    deriving (Attribute -> Attribute -> Bool
(Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool) -> Eq Attribute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
/= :: Attribute -> Attribute -> Bool
Eq, Eq Attribute
Eq Attribute =>
(Attribute -> Attribute -> Ordering)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Attribute)
-> (Attribute -> Attribute -> Attribute)
-> Ord Attribute
Attribute -> Attribute -> Bool
Attribute -> Attribute -> Ordering
Attribute -> Attribute -> Attribute
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
$ccompare :: Attribute -> Attribute -> Ordering
compare :: Attribute -> Attribute -> Ordering
$c< :: Attribute -> Attribute -> Bool
< :: Attribute -> Attribute -> Bool
$c<= :: Attribute -> Attribute -> Bool
<= :: Attribute -> Attribute -> Bool
$c> :: Attribute -> Attribute -> Bool
> :: Attribute -> Attribute -> Bool
$c>= :: Attribute -> Attribute -> Bool
>= :: Attribute -> Attribute -> Bool
$cmax :: Attribute -> Attribute -> Attribute
max :: Attribute -> Attribute -> Attribute
$cmin :: Attribute -> Attribute -> Attribute
min :: Attribute -> Attribute -> Attribute
Ord, Int -> Attribute -> String -> String
[Attribute] -> String -> String
Attribute -> String
(Int -> Attribute -> String -> String)
-> (Attribute -> String)
-> ([Attribute] -> String -> String)
-> Show Attribute
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Attribute -> String -> String
showsPrec :: Int -> Attribute -> String -> String
$cshow :: Attribute -> String
show :: Attribute -> String
$cshowList :: [Attribute] -> String -> String
showList :: [Attribute] -> String -> String
Show)

-- | The name of an entity block or extra block.
--
-- @since 2.17.1.0
newtype BlockKey = BlockKey Text
    deriving (Int -> BlockKey -> String -> String
[BlockKey] -> String -> String
BlockKey -> String
(Int -> BlockKey -> String -> String)
-> (BlockKey -> String)
-> ([BlockKey] -> String -> String)
-> Show BlockKey
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> BlockKey -> String -> String
showsPrec :: Int -> BlockKey -> String -> String
$cshow :: BlockKey -> String
show :: BlockKey -> String
$cshowList :: [BlockKey] -> String -> String
showList :: [BlockKey] -> String -> String
Show)

-- | A parsed comment or doc comment.
--
-- @since 2.16.0.0
data CommentToken
    = DocComment Text
    | Comment Text
    deriving (CommentToken -> CommentToken -> Bool
(CommentToken -> CommentToken -> Bool)
-> (CommentToken -> CommentToken -> Bool) -> Eq CommentToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommentToken -> CommentToken -> Bool
== :: CommentToken -> CommentToken -> Bool
$c/= :: CommentToken -> CommentToken -> Bool
/= :: CommentToken -> CommentToken -> Bool
Eq, Eq CommentToken
Eq CommentToken =>
(CommentToken -> CommentToken -> Ordering)
-> (CommentToken -> CommentToken -> Bool)
-> (CommentToken -> CommentToken -> Bool)
-> (CommentToken -> CommentToken -> Bool)
-> (CommentToken -> CommentToken -> Bool)
-> (CommentToken -> CommentToken -> CommentToken)
-> (CommentToken -> CommentToken -> CommentToken)
-> Ord CommentToken
CommentToken -> CommentToken -> Bool
CommentToken -> CommentToken -> Ordering
CommentToken -> CommentToken -> CommentToken
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
$ccompare :: CommentToken -> CommentToken -> Ordering
compare :: CommentToken -> CommentToken -> Ordering
$c< :: CommentToken -> CommentToken -> Bool
< :: CommentToken -> CommentToken -> Bool
$c<= :: CommentToken -> CommentToken -> Bool
<= :: CommentToken -> CommentToken -> Bool
$c> :: CommentToken -> CommentToken -> Bool
> :: CommentToken -> CommentToken -> Bool
$c>= :: CommentToken -> CommentToken -> Bool
>= :: CommentToken -> CommentToken -> Bool
$cmax :: CommentToken -> CommentToken -> CommentToken
max :: CommentToken -> CommentToken -> CommentToken
$cmin :: CommentToken -> CommentToken -> CommentToken
min :: CommentToken -> CommentToken -> CommentToken
Ord, Int -> CommentToken -> String -> String
[CommentToken] -> String -> String
CommentToken -> String
(Int -> CommentToken -> String -> String)
-> (CommentToken -> String)
-> ([CommentToken] -> String -> String)
-> Show CommentToken
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> CommentToken -> String -> String
showsPrec :: Int -> CommentToken -> String -> String
$cshow :: CommentToken -> String
show :: CommentToken -> String
$cshowList :: [CommentToken] -> String -> String
showList :: [CommentToken] -> String -> String
Show)

-- | Converts an attribute into a Text representation for second-stage parsing or
-- presentation to the user
--
-- @since 2.16.0.0
attributeContent :: Attribute -> Text
attributeContent :: Attribute -> Text
attributeContent = \case
    Assignment Text
l Text
r -> [Text] -> Text
forall m. Monoid m => [m] -> m
mconcat [Text
l, Text
"=", Text
r]
    Parenthetical Text
s -> Text
s
    PText Text
s -> Text
s
    Quotation Text
s -> Text
s

-- | Converts a directive into a Text representation for second-stage parsing or
-- presentation to the user
--
-- @since 2.17.1.0
directiveContent :: Directive -> [Text]
directiveContent :: Directive -> [Text]
directiveContent Directive
d =
    [DirectiveName -> Text
directiveNameContent (DirectiveName -> Text) -> DirectiveName -> Text
forall a b. (a -> b) -> a -> b
$ Directive -> DirectiveName
directiveName Directive
d]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Attribute -> Text
attributeContent (Attribute -> Text) -> [Attribute] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Directive -> [Attribute]
directiveAttributes Directive
d)

entityFieldContent :: EntityField -> [Text]
entityFieldContent :: EntityField -> [Text]
entityFieldContent EntityField
f =
    [ EntityField -> Text
fieldNameAndStrictnessAsText EntityField
f
    , (TypeExpr -> Text
typeExprContent (TypeExpr -> Text)
-> (EntityField -> TypeExpr) -> EntityField -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityField -> TypeExpr
entityFieldType) EntityField
f
    ]
        [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (Attribute -> Text) -> [Attribute] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attribute -> Text
attributeContent (EntityField -> [Attribute]
entityFieldAttributes EntityField
f)

blockKeyContent :: BlockKey -> Text
blockKeyContent :: BlockKey -> Text
blockKeyContent (BlockKey Text
t) = Text
t

directiveNameContent :: DirectiveName -> Text
directiveNameContent :: DirectiveName -> Text
directiveNameContent (DirectiveName Text
t) = Text
t

-- | Generates the field name of an EntityField, accompanied by
-- its strictness sigil, if one is present.
-- This is only needed temporarily, and can eventually be refactored away.
--
-- @since 2.17.1.0
fieldNameAndStrictnessAsText :: EntityField -> Text
fieldNameAndStrictnessAsText :: EntityField -> Text
fieldNameAndStrictnessAsText EntityField
f =
    let
        s :: Text
s = case EntityField -> Maybe FieldStrictness
entityFieldStrictness EntityField
f of
            Just FieldStrictness
Strict -> Text
"!"
            Just FieldStrictness
Lazy -> Text
"~"
            Maybe FieldStrictness
Nothing -> Text
""
        (FieldName Text
fn) = EntityField -> FieldName
entityFieldName EntityField
f
     in
        Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fn

commentContent :: CommentToken -> Text
commentContent :: CommentToken -> Text
commentContent = \case
    Comment Text
s -> Text
s
    DocComment Text
s -> Text
s

quotedAttributeErrorMessage :: String
quotedAttributeErrorMessage :: String
quotedAttributeErrorMessage = String
"Unexpected quotation mark in field or directive attribute"

attribute :: Parser Attribute
attribute :: Parser Attribute
attribute = do
    Maybe ParserErrorLevel
quotedFieldAttributeErrorLevel <- (PersistSettings -> Maybe ParserErrorLevel)
-> Parser (Maybe ParserErrorLevel)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PersistSettings -> Maybe ParserErrorLevel
psQuotedArgumentErrorLevel
    Maybe ParserErrorLevel
-> String
-> (ParseError String Void -> Bool)
-> Parser Attribute
-> Parser Attribute
-> Parser Attribute
forall a.
Maybe ParserErrorLevel
-> String
-> (ParseError String Void -> Bool)
-> Parser a
-> Parser a
-> Parser a
tryOrReport
        Maybe ParserErrorLevel
quotedFieldAttributeErrorLevel
        String
"Quoted field attributes are deprecated since 2.17.1.0, and will be removed in or after 2.18.0.0"
        ParseError String Void -> Bool
forall {e} {s}. Eq e => ParseError s e -> Bool
isQuotedAttributeError
        Parser Attribute
attribute'
        (Text -> Attribute
Quotation (Text -> Attribute) -> (String -> Text) -> String -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Attribute) -> Parser String -> Parser Attribute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
quotation)
  where
    isQuotedAttributeError :: ParseError s e -> Bool
isQuotedAttributeError (FancyError Int
_ Set (ErrorFancy e)
s) = Set (ErrorFancy e)
s Set (ErrorFancy e) -> Set (ErrorFancy e) -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorFancy e -> Set (ErrorFancy e)
forall a. a -> Set a
Set.singleton (String -> ErrorFancy e
forall e. String -> ErrorFancy e
ErrorFail String
quotedAttributeErrorMessage)
    isQuotedAttributeError ParseError s e
_ = Bool
False

attribute' :: Parser Attribute
attribute' :: Parser Attribute
attribute' = do
    Maybe Char
q <- Parser (Maybe Char) -> Parser (Maybe Char)
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Parser Char -> Parser (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Char -> Parser (Maybe Char))
-> Parser Char -> Parser (Maybe Char)
forall a b. (a -> b) -> a -> b
$ Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"')
    case Maybe Char
q of
        Just Char
_ -> String -> Parser Attribute
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
quotedAttributeErrorMessage
        Maybe Char
Nothing ->
            [Parser Attribute] -> Parser Attribute
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
                [ Parser Attribute -> Parser Attribute
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Attribute
assignment
                , Parser Attribute
parenthetical
                , Parser Attribute
ptext
                ]

docComment :: Parser (SourcePos, CommentToken)
docComment :: Parser (SourcePos, CommentToken)
docComment = do
    SourcePos
pos <- Parser SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    String
content <-
        Tokens String -> Parser (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"-- |" Parser (Tokens String) -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
validHSpace Parser () -> Parser String -> Parser String
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe String -> (Token String -> Bool) -> Parser (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"character") (Token String -> Token String -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token String
'\n')
    (SourcePos, CommentToken) -> Parser (SourcePos, CommentToken)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourcePos
pos, Text -> CommentToken
DocComment (String -> Text
Text.pack String
content))

comment :: Parser (SourcePos, CommentToken)
comment :: Parser (SourcePos, CommentToken)
comment = do
    SourcePos
pos <- Parser SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    String
content <-
        (Tokens String -> Parser (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"--" Parser (Tokens String)
-> Parser (Tokens String) -> Parser (Tokens String)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens String -> Parser (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"#")
            Parser (Tokens String) -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
validHSpace
            Parser () -> Parser String -> Parser String
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe String -> (Token String -> Bool) -> Parser (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"character") (Token String -> Token String -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token String
'\n')
    (SourcePos, CommentToken) -> Parser (SourcePos, CommentToken)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourcePos
pos, Text -> CommentToken
Comment (String -> Text
Text.pack String
content))

skipComment :: Parser ()
skipComment :: Parser ()
skipComment = do
    (SourcePos, CommentToken)
content <- Parser (SourcePos, CommentToken)
docComment Parser (SourcePos, CommentToken)
-> Parser (SourcePos, CommentToken)
-> Parser (SourcePos, CommentToken)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (SourcePos, CommentToken)
comment
    Parser () -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ (SourcePos, CommentToken) -> Parser ()
appendCommentToState (SourcePos, CommentToken)
content

isValidHSpace :: Bool -> Char -> Bool
isValidHSpace :: Bool -> Char -> Bool
isValidHSpace Bool
allowTabs Char
c =
    if Bool
allowTabs
        then Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n'
        else Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\t'

isValidSpace :: Bool -> Char -> Bool
isValidSpace :: Bool -> Char -> Bool
isValidSpace Bool
allowTabs Char
c =
    if Bool
allowTabs
        then Char -> Bool
isSpace Char
c
        else Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\t'

validSpaceParser
    :: (Maybe String -> (TMS.Token String -> Bool) -> Parser (Tokens String))
    -> (Bool -> Char -> Bool)
    -> Parser ()
validSpaceParser :: (Maybe String -> (Token String -> Bool) -> Parser (Tokens String))
-> (Bool -> Char -> Bool) -> Parser ()
validSpaceParser Maybe String -> (Token String -> Bool) -> Parser (Tokens String)
taker Bool -> Char -> Bool
validator = do
    Maybe ParserErrorLevel
tabErrorLevel <- (PersistSettings -> Maybe ParserErrorLevel)
-> Parser (Maybe ParserErrorLevel)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PersistSettings -> Maybe ParserErrorLevel
psTabErrorLevel
    Parser String -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser String -> Parser ()) -> Parser String -> Parser ()
forall a b. (a -> b) -> a -> b
$
        Maybe ParserErrorLevel
-> String
-> (ParseError String Void -> Bool)
-> Parser String
-> Parser String
-> Parser String
forall a.
Maybe ParserErrorLevel
-> String
-> (ParseError String Void -> Bool)
-> Parser a
-> Parser a
-> Parser a
tryOrReport
            Maybe ParserErrorLevel
tabErrorLevel
            String
"use spaces instead of tabs"
            ParseError String Void -> Bool
isUnexpectedTabError
            (Maybe String -> (Token String -> Bool) -> Parser (Tokens String)
taker (String -> Maybe String
forall a. a -> Maybe a
Just String
"valid whitespace") (Bool -> Char -> Bool
validator Bool
False))
            (Maybe String -> (Token String -> Bool) -> Parser (Tokens String)
taker (String -> Maybe String
forall a. a -> Maybe a
Just String
"valid whitespace") (Bool -> Char -> Bool
validator Bool
True))

isUnexpectedTabError :: ParseError String Void -> Bool
isUnexpectedTabError :: ParseError String Void -> Bool
isUnexpectedTabError (TrivialError Int
_ Maybe (ErrorItem (Token String))
ue Set (ErrorItem (Token String))
l) =
    Maybe (ErrorItem Char)
Maybe (ErrorItem (Token String))
ue Maybe (ErrorItem Char) -> Maybe (ErrorItem Char) -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorItem Char -> Maybe (ErrorItem Char)
forall a. a -> Maybe a
Just (NonEmpty Char -> ErrorItem Char
forall t. NonEmpty t -> ErrorItem t
Tokens (Char
'\t' Char -> String -> NonEmpty Char
forall a. a -> [a] -> NonEmpty a
:| String
""))
        Bool -> Bool -> Bool
&& Set (ErrorItem Char)
Set (ErrorItem (Token String))
l Set (ErrorItem Char) -> Set (ErrorItem Char) -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorItem Char -> Set (ErrorItem Char)
forall a. a -> Set a
Set.singleton (NonEmpty Char -> ErrorItem Char
forall t. NonEmpty Char -> ErrorItem t
Label (Char
'v' Char -> String -> NonEmpty Char
forall a. a -> [a] -> NonEmpty a
:| String
"alid whitespace"))
isUnexpectedTabError ParseError String Void
_ = Bool
False

someValidHSpace :: Parser ()
someValidHSpace :: Parser ()
someValidHSpace = (Maybe String -> (Token String -> Bool) -> Parser (Tokens String))
-> (Bool -> Char -> Bool) -> Parser ()
validSpaceParser Maybe String -> (Token String -> Bool) -> Parser (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Bool -> Char -> Bool
isValidHSpace

someValidSpace :: Parser ()
someValidSpace :: Parser ()
someValidSpace = (Maybe String -> (Token String -> Bool) -> Parser (Tokens String))
-> (Bool -> Char -> Bool) -> Parser ()
validSpaceParser Maybe String -> (Token String -> Bool) -> Parser (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Bool -> Char -> Bool
isValidSpace

validHSpace :: Parser ()
validHSpace :: Parser ()
validHSpace = (Maybe String -> (Token String -> Bool) -> Parser (Tokens String))
-> (Bool -> Char -> Bool) -> Parser ()
validSpaceParser Maybe String -> (Token String -> Bool) -> Parser (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Bool -> Char -> Bool
isValidHSpace

spaceConsumer :: Parser ()
spaceConsumer :: Parser ()
spaceConsumer =
    Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space
        Parser ()
someValidHSpace
        Parser ()
skipComment
        Parser ()
forall a. Parser a
forall (f :: * -> *) a. Alternative f => f a
empty

spaceConsumerN :: Parser ()
spaceConsumerN :: Parser ()
spaceConsumerN =
    Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space
        Parser ()
someValidSpace
        Parser ()
skipComment
        Parser ()
forall a. Parser a
forall (f :: * -> *) a. Alternative f => f a
empty

-- This catch-all character class is used in a variety of places, and includes characters
-- which have syntactic function. As we continue to iterate on the parser, we may want to consider
-- shrinking or eliminating `contentChar`.
contentChar :: Parser Char
contentChar :: Parser Char
contentChar =
    [Parser Char] -> Parser Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Parser Char
Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
        , Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'.'
        , Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'['
        , Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
']'
        , Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'_'
        , Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'\''
        , Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"'
        , Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'!'
        , Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'~'
        , Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-'
        , Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
':'
        , Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
','
        , do
            Char
backslash <- Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'\\'
            Char
nextChar <- Parser Char -> Parser Char
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead Parser Char
Parser (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
            if Char
nextChar Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
|| Char
nextChar Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')'
                then Token String -> Parser (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token String
nextChar
                else Char -> Parser Char
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
backslash
        ]

nonLineSpaceChar :: Parser Char
nonLineSpaceChar :: Parser Char
nonLineSpaceChar = [Parser Char] -> Parser Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
' ', Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'\t']

-- This is a replacement for `Text.Megaparsec.Char.Lexer.charLiteral`;
-- it does nearly the same thing but additionally supports escaped parentheses.
charLiteral :: Parser Char
charLiteral :: Parser Char
charLiteral = String -> Parser Char -> Parser Char
forall a. String -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"literal character" (Parser Char -> Parser Char) -> Parser Char -> Parser Char
forall a b. (a -> b) -> a -> b
$ do
    Char
char1 <- Parser Char
Parser (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
    case Char
char1 of
        Char
'\\' -> do
            Char
char2 <- Parser Char
Parser (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
            case Char
char2 of
                Char
'(' -> Char -> Parser Char
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'('
                Char
')' -> Char -> Parser Char
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
')'
                Char
'\\' -> Char -> Parser Char
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'\\'
                Char
'\"' -> Char -> Parser Char
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'\"'
                Char
'\'' -> Char -> Parser Char
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'\''
                Char
_ -> ErrorItem (Token String) -> Parser Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ErrorItem (Token s) -> m a
unexpected (NonEmpty (Token String) -> ErrorItem (Token String)
forall t. NonEmpty t -> ErrorItem t
Tokens (NonEmpty (Token String) -> ErrorItem (Token String))
-> NonEmpty (Token String) -> ErrorItem (Token String)
forall a b. (a -> b) -> a -> b
$ Char
char2 Char -> String -> NonEmpty Char
forall a. a -> [a] -> NonEmpty a
:| [])
        Char
_ -> Char -> Parser Char
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
char1

assignment :: Parser Attribute
assignment :: Parser Attribute
assignment = String -> Parser Attribute -> Parser Attribute
forall a. String -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"assignment expression" (Parser Attribute -> Parser Attribute)
-> Parser Attribute -> Parser Attribute
forall a b. (a -> b) -> a -> b
$ do
    Parser () -> Parser Attribute -> Parser Attribute
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer (Parser Attribute -> Parser Attribute)
-> Parser Attribute -> Parser Attribute
forall a b. (a -> b) -> a -> b
$ do
        String
lhs <- Parser Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser Char
contentChar
        Char
_ <- Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'='
        String
rhs <-
            [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
                [ Parser String
quotation
                , Parser String
sqlLiteral
                , Parser String
parentheticalInner
                , Parser String -> Parser String
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser String
sqlFunctionApplication
                , Parser Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (Parser Char -> Parser String) -> Parser Char -> Parser String
forall a b. (a -> b) -> a -> b
$ Parser Char
contentChar Parser Char -> Parser Char -> Parser Char
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'(' Parser Char -> Parser Char -> Parser Char
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
')'
                ]
        Attribute -> Parser Attribute
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> Parser Attribute) -> Attribute -> Parser Attribute
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Attribute
Assignment (String -> Text
Text.pack String
lhs) (String -> Text
Text.pack String
rhs)
  where
    parentheticalInner :: Parser String
parentheticalInner = do
        String
str <- Parser String
parenthetical'
        String -> Parser String
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Parser String)
-> (String -> String) -> String -> Parser String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. HasCallStack => [a] -> [a]
init (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> Parser String) -> String -> Parser String
forall a b. (a -> b) -> a -> b
$ String
str
    sqlFunctionApplication :: Parser String
sqlFunctionApplication = do
        String
fn <- Parser Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser Char
contentChar
        String
argString <- Parser String
parentheticalInner
        String -> Parser String
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Parser String) -> String -> Parser String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall m. Monoid m => [m] -> m
mconcat [String
fn, String
"(", String
argString, String
")"]

sqlTypeName :: Parser String
sqlTypeName :: Parser String
sqlTypeName =
    Parser Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (Parser Char -> Parser String) -> Parser Char -> Parser String
forall a b. (a -> b) -> a -> b
$
        [Parser Char] -> Parser Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
            [ Parser Char
Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
            , Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'_'
            ]

sqlLiteral :: Parser String
sqlLiteral :: Parser String
sqlLiteral = String -> Parser String -> Parser String
forall a. String -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"SQL literal" (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ do
    String
quote <- Parser () -> Parser String -> Parser String
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'\'' Parser Char -> Parser String -> Parser String
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char -> Parser Char -> Parser String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill Parser Char
charLiteral (Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'\'')
    Maybe String
st <- Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> Parser (Maybe String))
-> Parser String -> Parser (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
        String
colons <- Tokens String -> Parser (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
Tokens String
"::"
        String
tn <- Parser String
sqlTypeName
        String -> Parser String
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Parser String) -> String -> Parser String
forall a b. (a -> b) -> a -> b
$ String
colons String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tn
    String -> Parser String
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Parser String) -> String -> Parser String
forall a b. (a -> b) -> a -> b
$
        [String] -> String
forall m. Monoid m => [m] -> m
mconcat
            [ String
"'"
            , String
quote
            , String
"'"
            , String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
st
            ]

quotation :: Parser String
quotation :: Parser String
quotation = Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"' Parser Char -> Parser String -> Parser String
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char -> Parser Char -> Parser String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill Parser Char
charLiteral (Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"')

parenthetical :: Parser Attribute
parenthetical :: Parser Attribute
parenthetical = String -> Parser Attribute -> Parser Attribute
forall a. String -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"parenthetical" (Parser Attribute -> Parser Attribute)
-> Parser Attribute -> Parser Attribute
forall a b. (a -> b) -> a -> b
$ do
    String
str <- Parser () -> Parser String -> Parser String
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer Parser String
parenthetical'
    Attribute -> Parser Attribute
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> Parser Attribute)
-> (String -> Attribute) -> String -> Parser Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Attribute
Parenthetical (Text -> Attribute) -> (String -> Text) -> String -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. HasCallStack => [a] -> [a]
init (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> Parser Attribute) -> String -> Parser Attribute
forall a b. (a -> b) -> a -> b
$ String
str

parenthetical' :: Parser String
parenthetical' :: Parser String
parenthetical' = do
    String
str <- Parser Char -> Parser Char -> Parser String -> Parser String
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'(') (Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
')') Parser String
q
    String -> Parser String
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Parser String) -> String -> Parser String
forall a b. (a -> b) -> a -> b
$ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  where
    q :: Parser String
q = [String] -> String
forall m. Monoid m => [m] -> m
mconcat ([String] -> String) -> Parser [String] -> Parser String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String -> Parser [String]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (Parser String
c Parser String -> Parser String -> Parser String
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser String
parenthetical')
    c :: Parser String
c = (Char -> String -> String
forall a. a -> [a] -> [a]
: []) (Char -> String) -> Parser Char -> Parser String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Parser Char] -> Parser Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Parser Char
contentChar, Parser Char
nonLineSpaceChar, Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"']

blockKey :: Parser BlockKey
blockKey :: Parser BlockKey
blockKey = String -> Parser BlockKey -> Parser BlockKey
forall a. String -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"block key" (Parser BlockKey -> Parser BlockKey)
-> Parser BlockKey -> Parser BlockKey
forall a b. (a -> b) -> a -> b
$ do
    Char
fl <- Parser Char
Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar
    String
rl <- Parser Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Char
Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
    BlockKey -> Parser BlockKey
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockKey -> Parser BlockKey)
-> (String -> BlockKey) -> String -> Parser BlockKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> BlockKey
BlockKey (Text -> BlockKey) -> (String -> Text) -> String -> BlockKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Parser BlockKey) -> String -> Parser BlockKey
forall a b. (a -> b) -> a -> b
$ Char
fl Char -> String -> String
forall a. a -> [a] -> [a]
: String
rl

fieldStrictness :: Parser FieldStrictness
fieldStrictness :: Parser FieldStrictness
fieldStrictness =
    String -> Parser FieldStrictness -> Parser FieldStrictness
forall a. String -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"strictness sigil" (Parser FieldStrictness -> Parser FieldStrictness)
-> Parser FieldStrictness -> Parser FieldStrictness
forall a b. (a -> b) -> a -> b
$
        (FieldStrictness
Strict FieldStrictness -> Parser Char -> Parser FieldStrictness
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'!') Parser FieldStrictness
-> Parser FieldStrictness -> Parser FieldStrictness
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (FieldStrictness
Lazy FieldStrictness -> Parser Char -> Parser FieldStrictness
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'~')

fieldName :: Parser FieldName
fieldName :: Parser FieldName
fieldName = String -> Parser FieldName -> Parser FieldName
forall a. String -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"field name" (Parser FieldName -> Parser FieldName)
-> Parser FieldName -> Parser FieldName
forall a b. (a -> b) -> a -> b
$ do
    Char
fl <- Parser Char
Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
lowerChar
    String
rl <- Parser Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Char
fieldNameChar
    FieldName -> Parser FieldName
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> Parser FieldName)
-> (String -> FieldName) -> String -> Parser FieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FieldName
FieldName (Text -> FieldName) -> (String -> Text) -> String -> FieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Parser FieldName) -> String -> Parser FieldName
forall a b. (a -> b) -> a -> b
$ Char
fl Char -> String -> String
forall a. a -> [a] -> [a]
: String
rl
  where
    fieldNameChar :: Parser Char
fieldNameChar =
        [Parser Char] -> Parser Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
            [ Parser Char
Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
            , Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'_'
            ]

ptext :: Parser Attribute
ptext :: Parser Attribute
ptext = String -> Parser Attribute -> Parser Attribute
forall a. String -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"plain attribute" (Parser Attribute -> Parser Attribute)
-> Parser Attribute -> Parser Attribute
forall a b. (a -> b) -> a -> b
$ do
    String
str <- Parser () -> Parser String -> Parser String
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ Parser Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser Char
contentChar
    Attribute -> Parser Attribute
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> Parser Attribute)
-> (String -> Attribute) -> String -> Parser Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Attribute
PText (Text -> Attribute) -> (String -> Text) -> String -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Parser Attribute) -> String -> Parser Attribute
forall a b. (a -> b) -> a -> b
$ String
str

data ParsedEntityDef = ParsedEntityDef
    { ParsedEntityDef -> [Text]
parsedEntityDefComments :: [Text]
    , ParsedEntityDef -> EntityNameHS
parsedEntityDefEntityName :: EntityNameHS
    , ParsedEntityDef -> Bool
parsedEntityDefIsSum :: Bool
    , ParsedEntityDef -> [Attribute]
parsedEntityDefEntityAttributes :: [Attribute]
    , ParsedEntityDef -> [(EntityField, Maybe Text)]
parsedEntityDefFields :: [(EntityField, Maybe Text)]
    , ParsedEntityDef -> [(Directive, Maybe Text)]
parsedEntityDefDirectives :: [(Directive, Maybe Text)]
    , ParsedEntityDef -> Map Text [[Text]]
parsedEntityDefExtras :: M.Map Text [ExtraLine]
    , ParsedEntityDef -> Maybe SourceSpan
parsedEntityDefSpan :: Maybe SourceSpan
    }
    deriving (Int -> ParsedEntityDef -> String -> String
[ParsedEntityDef] -> String -> String
ParsedEntityDef -> String
(Int -> ParsedEntityDef -> String -> String)
-> (ParsedEntityDef -> String)
-> ([ParsedEntityDef] -> String -> String)
-> Show ParsedEntityDef
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ParsedEntityDef -> String -> String
showsPrec :: Int -> ParsedEntityDef -> String -> String
$cshow :: ParsedEntityDef -> String
show :: ParsedEntityDef -> String
$cshowList :: [ParsedEntityDef] -> String -> String
showList :: [ParsedEntityDef] -> String -> String
Show)

data DocCommentBlock = DocCommentBlock
    { DocCommentBlock -> [Text]
docCommentBlockLines :: [Text]
    , DocCommentBlock -> SourcePos
docCommentBlockPos :: SourcePos
    }
    deriving (Int -> DocCommentBlock -> String -> String
[DocCommentBlock] -> String -> String
DocCommentBlock -> String
(Int -> DocCommentBlock -> String -> String)
-> (DocCommentBlock -> String)
-> ([DocCommentBlock] -> String -> String)
-> Show DocCommentBlock
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DocCommentBlock -> String -> String
showsPrec :: Int -> DocCommentBlock -> String -> String
$cshow :: DocCommentBlock -> String
show :: DocCommentBlock -> String
$cshowList :: [DocCommentBlock] -> String -> String
showList :: [DocCommentBlock] -> String -> String
Show)

data EntityHeader = EntityHeader
    { EntityHeader -> Bool
entityHeaderSum :: Bool
    , EntityHeader -> Text
entityHeaderTableName :: Text
    , EntityHeader -> [Attribute]
entityHeaderRemainingAttributes :: [Attribute]
    , EntityHeader -> SourcePos
entityHeaderPos :: SourcePos
    }
    deriving (Int -> EntityHeader -> String -> String
[EntityHeader] -> String -> String
EntityHeader -> String
(Int -> EntityHeader -> String -> String)
-> (EntityHeader -> String)
-> ([EntityHeader] -> String -> String)
-> Show EntityHeader
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> EntityHeader -> String -> String
showsPrec :: Int -> EntityHeader -> String -> String
$cshow :: EntityHeader -> String
show :: EntityHeader -> String
$cshowList :: [EntityHeader] -> String -> String
showList :: [EntityHeader] -> String -> String
Show)

data EntityBlock = EntityBlock
    { EntityBlock -> Maybe DocCommentBlock
entityBlockDocCommentBlock :: Maybe DocCommentBlock
    , EntityBlock -> EntityHeader
entityBlockEntityHeader :: EntityHeader
    , EntityBlock -> [Member]
entityBlockMembers :: [Member]
    }
    deriving (Int -> EntityBlock -> String -> String
[EntityBlock] -> String -> String
EntityBlock -> String
(Int -> EntityBlock -> String -> String)
-> (EntityBlock -> String)
-> ([EntityBlock] -> String -> String)
-> Show EntityBlock
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> EntityBlock -> String -> String
showsPrec :: Int -> EntityBlock -> String -> String
$cshow :: EntityBlock -> String
show :: EntityBlock -> String
$cshowList :: [EntityBlock] -> String -> String
showList :: [EntityBlock] -> String -> String
Show)

entityBlockFirstPos :: EntityBlock -> SourcePos
entityBlockFirstPos :: EntityBlock -> SourcePos
entityBlockFirstPos = EntityHeader -> SourcePos
entityHeaderPos (EntityHeader -> SourcePos)
-> (EntityBlock -> EntityHeader) -> EntityBlock -> SourcePos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityBlock -> EntityHeader
entityBlockEntityHeader

entityBlockLastPos :: EntityBlock -> SourcePos
entityBlockLastPos :: EntityBlock -> SourcePos
entityBlockLastPos EntityBlock
eb = case EntityBlock -> [Member]
entityBlockMembers EntityBlock
eb of
    [] -> EntityBlock -> SourcePos
entityBlockFirstPos EntityBlock
eb
    [Member]
members -> [SourcePos] -> SourcePos
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([SourcePos] -> SourcePos) -> [SourcePos] -> SourcePos
forall a b. (a -> b) -> a -> b
$ (Member -> SourcePos) -> [Member] -> [SourcePos]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Member -> SourcePos
memberEndPos [Member]
members

entityBlockEntityFields :: EntityBlock -> [EntityField]
entityBlockEntityFields :: EntityBlock -> [EntityField]
entityBlockEntityFields = (Member -> [EntityField]) -> [Member] -> [EntityField]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Member -> [EntityField]
f ([Member] -> [EntityField])
-> (EntityBlock -> [Member]) -> EntityBlock -> [EntityField]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntityBlock -> [Member]
entityBlockMembers
  where
    f :: Member -> [EntityField]
f Member
m = case Member
m of
        MemberExtraBlock ExtraBlock
_ -> []
        MemberEntityField EntityField
ba -> [EntityField
ba]
        MemberDirective Directive
_ -> []

entityBlockExtraBlocks :: EntityBlock -> [ExtraBlock]
entityBlockExtraBlocks :: EntityBlock -> [ExtraBlock]
entityBlockExtraBlocks = (Member -> [ExtraBlock]) -> [Member] -> [ExtraBlock]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Member -> [ExtraBlock]
f ([Member] -> [ExtraBlock])
-> (EntityBlock -> [Member]) -> EntityBlock -> [ExtraBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntityBlock -> [Member]
entityBlockMembers
  where
    f :: Member -> [ExtraBlock]
f Member
m = case Member
m of
        MemberExtraBlock ExtraBlock
eb -> [ExtraBlock
eb]
        MemberEntityField EntityField
_ -> []
        MemberDirective Directive
_ -> []

entityBlockDirectives :: EntityBlock -> [Directive]
entityBlockDirectives :: EntityBlock -> [Directive]
entityBlockDirectives = (Member -> [Directive]) -> [Member] -> [Directive]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Member -> [Directive]
f ([Member] -> [Directive])
-> (EntityBlock -> [Member]) -> EntityBlock -> [Directive]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntityBlock -> [Member]
entityBlockMembers
  where
    f :: Member -> [Directive]
f Member
m = case Member
m of
        MemberExtraBlock ExtraBlock
_ -> []
        MemberEntityField EntityField
_ -> []
        MemberDirective Directive
bd -> [Directive
bd]

data ExtraBlockHeader = ExtraBlockHeader
    { ExtraBlockHeader -> Text
extraBlockHeaderKey :: Text
    , ExtraBlockHeader -> [Attribute]
extraBlockHeaderRemainingAttributes :: [Attribute]
    , ExtraBlockHeader -> SourcePos
extraBlockHeaderPos :: SourcePos
    }
    deriving (Int -> ExtraBlockHeader -> String -> String
[ExtraBlockHeader] -> String -> String
ExtraBlockHeader -> String
(Int -> ExtraBlockHeader -> String -> String)
-> (ExtraBlockHeader -> String)
-> ([ExtraBlockHeader] -> String -> String)
-> Show ExtraBlockHeader
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ExtraBlockHeader -> String -> String
showsPrec :: Int -> ExtraBlockHeader -> String -> String
$cshow :: ExtraBlockHeader -> String
show :: ExtraBlockHeader -> String
$cshowList :: [ExtraBlockHeader] -> String -> String
showList :: [ExtraBlockHeader] -> String -> String
Show)

data ExtraBlock = ExtraBlock
    { ExtraBlock -> Maybe DocCommentBlock
extraBlockDocCommentBlock :: Maybe DocCommentBlock
    , ExtraBlock -> ExtraBlockHeader
extraBlockExtraBlockHeader :: ExtraBlockHeader
    , ExtraBlock -> NonEmpty ExtraBlockLine
extraBlockLines :: NonEmpty ExtraBlockLine
    }
    deriving (Int -> ExtraBlock -> String -> String
[ExtraBlock] -> String -> String
ExtraBlock -> String
(Int -> ExtraBlock -> String -> String)
-> (ExtraBlock -> String)
-> ([ExtraBlock] -> String -> String)
-> Show ExtraBlock
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ExtraBlock -> String -> String
showsPrec :: Int -> ExtraBlock -> String -> String
$cshow :: ExtraBlock -> String
show :: ExtraBlock -> String
$cshowList :: [ExtraBlock] -> String -> String
showList :: [ExtraBlock] -> String -> String
Show)

data FieldStrictness = Strict | Lazy
    deriving (Int -> FieldStrictness -> String -> String
[FieldStrictness] -> String -> String
FieldStrictness -> String
(Int -> FieldStrictness -> String -> String)
-> (FieldStrictness -> String)
-> ([FieldStrictness] -> String -> String)
-> Show FieldStrictness
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FieldStrictness -> String -> String
showsPrec :: Int -> FieldStrictness -> String -> String
$cshow :: FieldStrictness -> String
show :: FieldStrictness -> String
$cshowList :: [FieldStrictness] -> String -> String
showList :: [FieldStrictness] -> String -> String
Show)

newtype FieldName = FieldName Text
    deriving (Int -> FieldName -> String -> String
[FieldName] -> String -> String
FieldName -> String
(Int -> FieldName -> String -> String)
-> (FieldName -> String)
-> ([FieldName] -> String -> String)
-> Show FieldName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FieldName -> String -> String
showsPrec :: Int -> FieldName -> String -> String
$cshow :: FieldName -> String
show :: FieldName -> String
$cshowList :: [FieldName] -> String -> String
showList :: [FieldName] -> String -> String
Show, FieldName -> FieldName -> Bool
(FieldName -> FieldName -> Bool)
-> (FieldName -> FieldName -> Bool) -> Eq FieldName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldName -> FieldName -> Bool
== :: FieldName -> FieldName -> Bool
$c/= :: FieldName -> FieldName -> Bool
/= :: FieldName -> FieldName -> Bool
Eq)

newtype DirectiveName = DirectiveName Text
    deriving (Int -> DirectiveName -> String -> String
[DirectiveName] -> String -> String
DirectiveName -> String
(Int -> DirectiveName -> String -> String)
-> (DirectiveName -> String)
-> ([DirectiveName] -> String -> String)
-> Show DirectiveName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DirectiveName -> String -> String
showsPrec :: Int -> DirectiveName -> String -> String
$cshow :: DirectiveName -> String
show :: DirectiveName -> String
$cshowList :: [DirectiveName] -> String -> String
showList :: [DirectiveName] -> String -> String
Show, DirectiveName -> DirectiveName -> Bool
(DirectiveName -> DirectiveName -> Bool)
-> (DirectiveName -> DirectiveName -> Bool) -> Eq DirectiveName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DirectiveName -> DirectiveName -> Bool
== :: DirectiveName -> DirectiveName -> Bool
$c/= :: DirectiveName -> DirectiveName -> Bool
/= :: DirectiveName -> DirectiveName -> Bool
Eq)

data EntityField = EntityField
    { EntityField -> Maybe DocCommentBlock
entityFieldDocCommentBlock :: Maybe DocCommentBlock
    , EntityField -> Maybe FieldStrictness
entityFieldStrictness :: Maybe FieldStrictness
    , EntityField -> FieldName
entityFieldName :: FieldName
    , EntityField -> TypeExpr
entityFieldType :: TypeExpr
    , EntityField -> [Attribute]
entityFieldAttributes :: [Attribute]
    , EntityField -> SourcePos
entityFieldPos :: SourcePos
    }
    deriving (Int -> EntityField -> String -> String
[EntityField] -> String -> String
EntityField -> String
(Int -> EntityField -> String -> String)
-> (EntityField -> String)
-> ([EntityField] -> String -> String)
-> Show EntityField
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> EntityField -> String -> String
showsPrec :: Int -> EntityField -> String -> String
$cshow :: EntityField -> String
show :: EntityField -> String
$cshowList :: [EntityField] -> String -> String
showList :: [EntityField] -> String -> String
Show)

data Directive = Directive
    { Directive -> Maybe DocCommentBlock
directiveDocCommentBlock :: Maybe DocCommentBlock
    , Directive -> DirectiveName
directiveName :: DirectiveName
    , Directive -> [Attribute]
directiveAttributes :: [Attribute]
    , Directive -> SourcePos
directivePos :: SourcePos
    }
    deriving (Int -> Directive -> String -> String
[Directive] -> String -> String
Directive -> String
(Int -> Directive -> String -> String)
-> (Directive -> String)
-> ([Directive] -> String -> String)
-> Show Directive
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Directive -> String -> String
showsPrec :: Int -> Directive -> String -> String
$cshow :: Directive -> String
show :: Directive -> String
$cshowList :: [Directive] -> String -> String
showList :: [Directive] -> String -> String
Show)

data Member
    = MemberExtraBlock ExtraBlock
    | MemberEntityField EntityField
    | MemberDirective Directive
    deriving (Int -> Member -> String -> String
[Member] -> String -> String
Member -> String
(Int -> Member -> String -> String)
-> (Member -> String)
-> ([Member] -> String -> String)
-> Show Member
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Member -> String -> String
showsPrec :: Int -> Member -> String -> String
$cshow :: Member -> String
show :: Member -> String
$cshowList :: [Member] -> String -> String
showList :: [Member] -> String -> String
Show)

data ExtraBlockLine = ExtraBlockLine
    { ExtraBlockLine -> Maybe DocCommentBlock
extraBlockLineDocCommentBlock :: Maybe DocCommentBlock
    , ExtraBlockLine -> [String]
extraBlockLineTokens :: [String]
    , ExtraBlockLine -> SourcePos
extraBlockLinePos :: SourcePos
    }
    deriving (Int -> ExtraBlockLine -> String -> String
[ExtraBlockLine] -> String -> String
ExtraBlockLine -> String
(Int -> ExtraBlockLine -> String -> String)
-> (ExtraBlockLine -> String)
-> ([ExtraBlockLine] -> String -> String)
-> Show ExtraBlockLine
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ExtraBlockLine -> String -> String
showsPrec :: Int -> ExtraBlockLine -> String -> String
$cshow :: ExtraBlockLine -> String
show :: ExtraBlockLine -> String
$cshowList :: [ExtraBlockLine] -> String -> String
showList :: [ExtraBlockLine] -> String -> String
Show)

-- | The source position at the beginning of the member's final line.
memberEndPos :: Member -> SourcePos
memberEndPos :: Member -> SourcePos
memberEndPos (MemberEntityField EntityField
fs) = EntityField -> SourcePos
entityFieldPos EntityField
fs
memberEndPos (MemberDirective Directive
d) = Directive -> SourcePos
directivePos Directive
d
memberEndPos (MemberExtraBlock ExtraBlock
ex) = ExtraBlockLine -> SourcePos
extraBlockLinePos (ExtraBlockLine -> SourcePos)
-> (ExtraBlock -> ExtraBlockLine) -> ExtraBlock -> SourcePos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ExtraBlockLine -> ExtraBlockLine
forall a. NonEmpty a -> a
NEL.last (NonEmpty ExtraBlockLine -> ExtraBlockLine)
-> (ExtraBlock -> NonEmpty ExtraBlockLine)
-> ExtraBlock
-> ExtraBlockLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtraBlock -> NonEmpty ExtraBlockLine
extraBlockLines (ExtraBlock -> SourcePos) -> ExtraBlock -> SourcePos
forall a b. (a -> b) -> a -> b
$ ExtraBlock
ex

-- | Represents an entity member as a list of EntityFields
--
-- @since 2.16.0.0
memberEntityFields :: Member -> [EntityField]
memberEntityFields :: Member -> [EntityField]
memberEntityFields (MemberEntityField EntityField
fs) = [EntityField
fs]
memberEntityFields (MemberDirective Directive
_) = []
memberEntityFields (MemberExtraBlock ExtraBlock
_) = []

extraBlocksAsMap :: [ExtraBlock] -> M.Map Text [ExtraLine]
extraBlocksAsMap :: [ExtraBlock] -> Map Text [[Text]]
extraBlocksAsMap [ExtraBlock]
exs = [(Text, [[Text]])] -> Map Text [[Text]]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, [[Text]])] -> Map Text [[Text]])
-> [(Text, [[Text]])] -> Map Text [[Text]]
forall a b. (a -> b) -> a -> b
$ (ExtraBlock -> (Text, [[Text]]))
-> [ExtraBlock] -> [(Text, [[Text]])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExtraBlock -> (Text, [[Text]])
asPair [ExtraBlock]
exs
  where
    asPair :: ExtraBlock -> (Text, [[Text]])
asPair ExtraBlock
ex =
        ( ExtraBlockHeader -> Text
extraBlockHeaderKey (ExtraBlockHeader -> Text)
-> (ExtraBlock -> ExtraBlockHeader) -> ExtraBlock -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtraBlock -> ExtraBlockHeader
extraBlockExtraBlockHeader (ExtraBlock -> Text) -> ExtraBlock -> Text
forall a b. (a -> b) -> a -> b
$ ExtraBlock
ex
        , NonEmpty [Text] -> [[Text]]
forall a. NonEmpty a -> [a]
NEL.toList (ExtraBlock -> NonEmpty [Text]
extraLines ExtraBlock
ex)
        )
    extraLines :: ExtraBlock -> NonEmpty [Text]
    extraLines :: ExtraBlock -> NonEmpty [Text]
extraLines ExtraBlock
ex = (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
Text.pack ([String] -> [Text])
-> (ExtraBlockLine -> [String]) -> ExtraBlockLine -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtraBlockLine -> [String]
extraBlockLineTokens (ExtraBlockLine -> [Text])
-> NonEmpty ExtraBlockLine -> NonEmpty [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtraBlock -> NonEmpty ExtraBlockLine
extraBlockLines ExtraBlock
ex

entityHeader :: Parser EntityHeader
entityHeader :: Parser EntityHeader
entityHeader = do
    SourcePos
pos <- Parser SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    Maybe Char
plus <- Parser Char -> Parser (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token String -> Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'+')
    BlockKey
en <- Parser ()
validHSpace Parser () -> Parser BlockKey -> Parser BlockKey
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parser BlockKey -> Parser BlockKey
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer Parser BlockKey
blockKey
    [Attribute]
rest <- Parser () -> Parser [Attribute] -> Parser [Attribute]
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer (Parser Attribute -> Parser [Attribute]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Attribute
attribute)
    ()
_ <- Parser ()
setLastDocumentablePosition
    EntityHeader -> Parser EntityHeader
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        EntityHeader
            { entityHeaderSum :: Bool
entityHeaderSum = Maybe Char -> Bool
forall a. Maybe a -> Bool
isJust Maybe Char
plus
            , entityHeaderTableName :: Text
entityHeaderTableName = BlockKey -> Text
blockKeyContent BlockKey
en
            , entityHeaderRemainingAttributes :: [Attribute]
entityHeaderRemainingAttributes = [Attribute]
rest
            , entityHeaderPos :: SourcePos
entityHeaderPos = SourcePos
pos
            }

appendCommentToState :: (SourcePos, CommentToken) -> Parser ()
appendCommentToState :: (SourcePos, CommentToken) -> Parser ()
appendCommentToState (SourcePos, CommentToken)
ptok =
    (ExtraState -> ExtraState) -> Parser ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ExtraState -> ExtraState) -> Parser ())
-> (ExtraState -> ExtraState) -> Parser ()
forall a b. (a -> b) -> a -> b
$ \ExtraState
es ->
        let
            comments :: [(SourcePos, CommentToken)]
comments = ExtraState -> [(SourcePos, CommentToken)]
esPositionedCommentTokens ExtraState
es
         in
            ExtraState
es{esPositionedCommentTokens = ptok : comments}

setLastDocumentablePosition :: Parser ()
setLastDocumentablePosition :: Parser ()
setLastDocumentablePosition = do
    SourcePos
pos <- Parser SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    (ExtraState -> ExtraState) -> Parser ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ExtraState -> ExtraState) -> Parser ())
-> (ExtraState -> ExtraState) -> Parser ()
forall a b. (a -> b) -> a -> b
$ \ExtraState
es -> ExtraState
es{esLastDocumentablePosition = Just pos}

getDcb :: Parser (Maybe DocCommentBlock)
getDcb :: Parser (Maybe DocCommentBlock)
getDcb = do
    ExtraState
es <- Parser ExtraState
forall s (m :: * -> *). MonadState s m => m s
get
    let
        comments :: [(SourcePos, CommentToken)]
comments = [(SourcePos, CommentToken)] -> [(SourcePos, CommentToken)]
forall a. [a] -> [a]
reverse ([(SourcePos, CommentToken)] -> [(SourcePos, CommentToken)])
-> [(SourcePos, CommentToken)] -> [(SourcePos, CommentToken)]
forall a b. (a -> b) -> a -> b
$ ExtraState -> [(SourcePos, CommentToken)]
esPositionedCommentTokens ExtraState
es
    ()
_ <- ExtraState -> Parser ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ExtraState
es{esPositionedCommentTokens = []}
    let
        candidates :: [(SourcePos, CommentToken)]
candidates = ((SourcePos, CommentToken) -> Bool)
-> [(SourcePos, CommentToken)] -> [(SourcePos, CommentToken)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\(SourcePos
_sp, CommentToken
ct) -> Bool -> Bool
not (CommentToken -> Bool
isDocComment CommentToken
ct)) [(SourcePos, CommentToken)]
comments
        filteredCandidates :: [(SourcePos, CommentToken)]
filteredCandidates = ((SourcePos, CommentToken) -> Bool)
-> [(SourcePos, CommentToken)] -> [(SourcePos, CommentToken)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (ExtraState -> (SourcePos, CommentToken) -> Bool
commentIsIncorrectlyPositioned ExtraState
es) [(SourcePos, CommentToken)]
candidates
    Maybe DocCommentBlock -> Parser (Maybe DocCommentBlock)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DocCommentBlock -> Parser (Maybe DocCommentBlock))
-> Maybe DocCommentBlock -> Parser (Maybe DocCommentBlock)
forall a b. (a -> b) -> a -> b
$ [(SourcePos, CommentToken)] -> Maybe DocCommentBlock
docCommentBlockFromPositionedAttributes [(SourcePos, CommentToken)]
filteredCandidates
  where
    commentIsIncorrectlyPositioned
        :: ExtraState -> (SourcePos, CommentToken) -> Bool
    commentIsIncorrectlyPositioned :: ExtraState -> (SourcePos, CommentToken) -> Bool
commentIsIncorrectlyPositioned ExtraState
es (SourcePos, CommentToken)
ptok = case ExtraState -> Maybe SourcePos
esLastDocumentablePosition ExtraState
es of
        Maybe SourcePos
Nothing -> Bool
False
        Just SourcePos
lastDocumentablePos -> (SourcePos -> Pos
sourceLine (SourcePos -> Pos)
-> ((SourcePos, CommentToken) -> SourcePos)
-> (SourcePos, CommentToken)
-> Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourcePos, CommentToken) -> SourcePos
forall a b. (a, b) -> a
fst) (SourcePos, CommentToken)
ptok Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
<= SourcePos -> Pos
sourceLine SourcePos
lastDocumentablePos

extraBlock :: Parser Member
extraBlock :: Parser Member
extraBlock = Parser ()
-> Parser (IndentOpt Parser Member ExtraBlockLine) -> Parser Member
forall s e (m :: * -> *) a b.
(TraversableStream s, MonadParsec e s m, Token s ~ Char) =>
m () -> m (IndentOpt m a b) -> m a
L.indentBlock Parser ()
spaceConsumerN Parser (IndentOpt Parser Member ExtraBlockLine)
innerParser
  where
    mkExtraBlockMember :: Maybe DocCommentBlock
-> (ExtraBlockHeader, [ExtraBlockLine]) -> Member
mkExtraBlockMember Maybe DocCommentBlock
dcb (ExtraBlockHeader
header, [ExtraBlockLine]
extraBlockLines) =
        ExtraBlock -> Member
MemberExtraBlock
            ExtraBlock
                { extraBlockExtraBlockHeader :: ExtraBlockHeader
extraBlockExtraBlockHeader = ExtraBlockHeader
header
                , extraBlockLines :: NonEmpty ExtraBlockLine
extraBlockLines = [ExtraBlockLine] -> NonEmpty ExtraBlockLine
forall {a}. [a] -> NonEmpty a
ensureNonEmpty [ExtraBlockLine]
extraBlockLines
                , extraBlockDocCommentBlock :: Maybe DocCommentBlock
extraBlockDocCommentBlock = Maybe DocCommentBlock
dcb
                }
    ensureNonEmpty :: [a] -> NonEmpty a
ensureNonEmpty [a]
lines = case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [a]
lines of
        Just NonEmpty a
nel -> NonEmpty a
nel
        Maybe (NonEmpty a)
Nothing -> String -> NonEmpty a
forall a. HasCallStack => String -> a
error String
"unreachable" -- lines is known to be non-empty
    innerParser :: Parser (IndentOpt Parser Member ExtraBlockLine)
innerParser = do
        Maybe DocCommentBlock
dcb <- Parser (Maybe DocCommentBlock)
getDcb
        ExtraBlockHeader
header <- Parser ExtraBlockHeader
extraBlockHeader
        IndentOpt Parser Member ExtraBlockLine
-> Parser (IndentOpt Parser Member ExtraBlockLine)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IndentOpt Parser Member ExtraBlockLine
 -> Parser (IndentOpt Parser Member ExtraBlockLine))
-> IndentOpt Parser Member ExtraBlockLine
-> Parser (IndentOpt Parser Member ExtraBlockLine)
forall a b. (a -> b) -> a -> b
$
            Maybe Pos
-> ([ExtraBlockLine] -> Parser Member)
-> Parser ExtraBlockLine
-> IndentOpt Parser Member ExtraBlockLine
forall (m :: * -> *) a b.
Maybe Pos -> ([b] -> m a) -> m b -> IndentOpt m a b
L.IndentSome
                Maybe Pos
forall a. Maybe a
Nothing
                (Member -> Parser Member
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Member -> Parser Member)
-> ([ExtraBlockLine] -> Member)
-> [ExtraBlockLine]
-> Parser Member
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe DocCommentBlock
-> (ExtraBlockHeader, [ExtraBlockLine]) -> Member
mkExtraBlockMember Maybe DocCommentBlock
dcb ((ExtraBlockHeader, [ExtraBlockLine]) -> Member)
-> ([ExtraBlockLine] -> (ExtraBlockHeader, [ExtraBlockLine]))
-> [ExtraBlockLine]
-> Member
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExtraBlockHeader
header,))
                Parser ExtraBlockLine
extraBlockLine

extraBlockHeader :: Parser ExtraBlockHeader
extraBlockHeader :: Parser ExtraBlockHeader
extraBlockHeader = do
    SourcePos
pos <- Parser SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    BlockKey
tn <- Parser () -> Parser BlockKey -> Parser BlockKey
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer Parser BlockKey
blockKey
    [Attribute]
rest <- Parser () -> Parser [Attribute] -> Parser [Attribute]
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer (Parser Attribute -> Parser [Attribute]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Attribute
attribute)
    ()
_ <- Parser ()
setLastDocumentablePosition
    ExtraBlockHeader -> Parser ExtraBlockHeader
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExtraBlockHeader -> Parser ExtraBlockHeader)
-> ExtraBlockHeader -> Parser ExtraBlockHeader
forall a b. (a -> b) -> a -> b
$
        ExtraBlockHeader
            { extraBlockHeaderKey :: Text
extraBlockHeaderKey = BlockKey -> Text
blockKeyContent BlockKey
tn
            , extraBlockHeaderRemainingAttributes :: [Attribute]
extraBlockHeaderRemainingAttributes = [Attribute]
rest
            , extraBlockHeaderPos :: SourcePos
extraBlockHeaderPos = SourcePos
pos
            }

extraBlockLine :: Parser ExtraBlockLine
extraBlockLine :: Parser ExtraBlockLine
extraBlockLine = do
    Maybe DocCommentBlock
dcb <- Parser (Maybe DocCommentBlock)
getDcb
    SourcePos
pos <- Parser SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    [String]
tokens <- Parser String -> Parser [String]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (Parser String -> Parser [String])
-> Parser String -> Parser [String]
forall a b. (a -> b) -> a -> b
$ Parser () -> Parser String -> Parser String
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer (Parser Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser Char
contentChar)
    ()
_ <- Parser ()
setLastDocumentablePosition
    ExtraBlockLine -> Parser ExtraBlockLine
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExtraBlockLine -> Parser ExtraBlockLine)
-> ExtraBlockLine -> Parser ExtraBlockLine
forall a b. (a -> b) -> a -> b
$
        ExtraBlockLine
            { extraBlockLineDocCommentBlock :: Maybe DocCommentBlock
extraBlockLineDocCommentBlock = Maybe DocCommentBlock
dcb
            , extraBlockLineTokens :: [String]
extraBlockLineTokens = [String]
tokens
            , extraBlockLinePos :: SourcePos
extraBlockLinePos = SourcePos
pos
            }

entityField :: Parser Member
entityField :: Parser Member
entityField = do
    Maybe DocCommentBlock
dcb <- Parser (Maybe DocCommentBlock)
getDcb
    SourcePos
pos <- Parser SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    Maybe FieldStrictness
ss <- Parser FieldStrictness -> Parser (Maybe FieldStrictness)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser FieldStrictness
fieldStrictness
    FieldName
fn <- Parser () -> Parser FieldName -> Parser FieldName
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer Parser FieldName
fieldName
    TypeExpr
ft <- Parser () -> Parser TypeExpr -> Parser TypeExpr
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer Parser TypeExpr
forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
typeExpr -- Note that `typeExpr` consumes outer parentheses.
    [Attribute]
fa <- Parser () -> Parser [Attribute] -> Parser [Attribute]
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer (Parser Attribute -> Parser [Attribute]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Attribute
attribute)
    ()
_ <- Parser ()
setLastDocumentablePosition
    Parser () -> Parser ()
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Parser Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser Char
Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline Parser () -> Parser () -> Parser ()
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)
    Member -> Parser Member
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Member -> Parser Member) -> Member -> Parser Member
forall a b. (a -> b) -> a -> b
$
        EntityField -> Member
MemberEntityField
            EntityField
                { entityFieldDocCommentBlock :: Maybe DocCommentBlock
entityFieldDocCommentBlock = Maybe DocCommentBlock
dcb
                , entityFieldStrictness :: Maybe FieldStrictness
entityFieldStrictness = Maybe FieldStrictness
ss
                , entityFieldName :: FieldName
entityFieldName = FieldName
fn
                , entityFieldType :: TypeExpr
entityFieldType = TypeExpr
ft
                , entityFieldAttributes :: [Attribute]
entityFieldAttributes = [Attribute]
fa
                , entityFieldPos :: SourcePos
entityFieldPos = SourcePos
pos
                }

directiveNameP :: Parser DirectiveName
directiveNameP :: Parser DirectiveName
directiveNameP =
    String -> Parser DirectiveName -> Parser DirectiveName
forall a. String -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"directive name" (Parser DirectiveName -> Parser DirectiveName)
-> Parser DirectiveName -> Parser DirectiveName
forall a b. (a -> b) -> a -> b
$
        Text -> DirectiveName
DirectiveName (Text -> DirectiveName)
-> (String -> Text) -> String -> DirectiveName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
            (String -> DirectiveName) -> Parser String -> Parser DirectiveName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
                [ Tokens String -> Parser (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
Tokens String
"deriving"
                , Parser String
directiveName'
                ]
  where
    directiveName' :: Parser String
directiveName' = do
        Char
fl <- Parser Char
Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar
        String
rl <- Parser Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Char
Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
        String -> Parser String
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
fl Char -> String -> String
forall a. a -> [a] -> [a]
: String
rl)

directive :: Parser Member
directive :: Parser Member
directive = do
    Maybe DocCommentBlock
dcb <- Parser (Maybe DocCommentBlock)
getDcb
    SourcePos
pos <- Parser SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    DirectiveName
dn <- Parser () -> Parser DirectiveName -> Parser DirectiveName
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer Parser DirectiveName
directiveNameP
    [Attribute]
args <- Parser Attribute -> Parser [Attribute]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Parser Attribute -> Parser [Attribute])
-> Parser Attribute -> Parser [Attribute]
forall a b. (a -> b) -> a -> b
$ Parser () -> Parser Attribute -> Parser Attribute
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer Parser Attribute
attribute
    ()
_ <- Parser ()
setLastDocumentablePosition
    Parser () -> Parser ()
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Parser Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser Char
Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline Parser () -> Parser () -> Parser ()
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)
    Member -> Parser Member
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Member -> Parser Member) -> Member -> Parser Member
forall a b. (a -> b) -> a -> b
$
        Directive -> Member
MemberDirective
            Directive
                { directiveDocCommentBlock :: Maybe DocCommentBlock
directiveDocCommentBlock = Maybe DocCommentBlock
dcb
                , directiveName :: DirectiveName
directiveName = DirectiveName
dn
                , directiveAttributes :: [Attribute]
directiveAttributes = [Attribute]
args
                , directivePos :: SourcePos
directivePos = SourcePos
pos
                }

member :: Parser Member
member :: Parser Member
member =
    [Parser Member] -> Parser Member
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Parser Member -> Parser Member
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Member
extraBlock
        , Parser Member
directive
        , Parser Member
entityField
        ]

entityBlock :: Parser EntityBlock
entityBlock :: Parser EntityBlock
entityBlock = do
    Parser ()
-> Parser (IndentOpt Parser EntityBlock Member)
-> Parser EntityBlock
forall s e (m :: * -> *) a b.
(TraversableStream s, MonadParsec e s m, Token s ~ Char) =>
m () -> m (IndentOpt m a b) -> m a
L.indentBlock Parser ()
spaceConsumerN Parser (IndentOpt Parser EntityBlock Member)
innerParser
  where
    mkEntityBlock :: Maybe DocCommentBlock -> (EntityHeader, [Member]) -> EntityBlock
mkEntityBlock Maybe DocCommentBlock
dcb (EntityHeader
header, [Member]
members) =
        EntityBlock
            { entityBlockEntityHeader :: EntityHeader
entityBlockEntityHeader = EntityHeader
header
            , entityBlockMembers :: [Member]
entityBlockMembers = [Member]
members
            , entityBlockDocCommentBlock :: Maybe DocCommentBlock
entityBlockDocCommentBlock = Maybe DocCommentBlock
dcb
            }
    innerParser :: Parser (IndentOpt Parser EntityBlock Member)
innerParser = do
        Maybe DocCommentBlock
dcb <- Parser (Maybe DocCommentBlock)
getDcb
        EntityHeader
header <- Parser EntityHeader
entityHeader
        IndentOpt Parser EntityBlock Member
-> Parser (IndentOpt Parser EntityBlock Member)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IndentOpt Parser EntityBlock Member
 -> Parser (IndentOpt Parser EntityBlock Member))
-> IndentOpt Parser EntityBlock Member
-> Parser (IndentOpt Parser EntityBlock Member)
forall a b. (a -> b) -> a -> b
$ Maybe Pos
-> ([Member] -> Parser EntityBlock)
-> Parser Member
-> IndentOpt Parser EntityBlock Member
forall (m :: * -> *) a b.
Maybe Pos -> ([b] -> m a) -> m b -> IndentOpt m a b
L.IndentMany Maybe Pos
forall a. Maybe a
Nothing (EntityBlock -> Parser EntityBlock
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (EntityBlock -> Parser EntityBlock)
-> ([Member] -> EntityBlock) -> [Member] -> Parser EntityBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe DocCommentBlock -> (EntityHeader, [Member]) -> EntityBlock
mkEntityBlock Maybe DocCommentBlock
dcb ((EntityHeader, [Member]) -> EntityBlock)
-> ([Member] -> (EntityHeader, [Member]))
-> [Member]
-> EntityBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EntityHeader
header,)) Parser Member
member

entitiesFromDocument :: Parser [EntityBlock]
entitiesFromDocument :: Parser [EntityBlock]
entitiesFromDocument = Parser EntityBlock -> Parser [EntityBlock]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser EntityBlock
entityBlock

docCommentBlockText :: DocCommentBlock -> Text
docCommentBlockText :: DocCommentBlock -> Text
docCommentBlockText DocCommentBlock
dcb = [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ DocCommentBlock -> [Text]
docCommentBlockLines DocCommentBlock
dcb

isDocComment :: CommentToken -> Bool
isDocComment :: CommentToken -> Bool
isDocComment CommentToken
tok = case CommentToken
tok of
    DocComment Text
_ -> Bool
True
    CommentToken
_ -> Bool
False

docCommentBlockFromPositionedAttributes
    :: [(SourcePos, CommentToken)] -> Maybe DocCommentBlock
docCommentBlockFromPositionedAttributes :: [(SourcePos, CommentToken)] -> Maybe DocCommentBlock
docCommentBlockFromPositionedAttributes [(SourcePos, CommentToken)]
ptoks =
    case [(SourcePos, CommentToken)]
-> Maybe (NonEmpty (SourcePos, CommentToken))
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [(SourcePos, CommentToken)]
ptoks of
        Maybe (NonEmpty (SourcePos, CommentToken))
Nothing -> Maybe DocCommentBlock
forall a. Maybe a
Nothing
        Just NonEmpty (SourcePos, CommentToken)
nel ->
            DocCommentBlock -> Maybe DocCommentBlock
forall a. a -> Maybe a
Just (DocCommentBlock -> Maybe DocCommentBlock)
-> DocCommentBlock -> Maybe DocCommentBlock
forall a b. (a -> b) -> a -> b
$
                DocCommentBlock
                    { docCommentBlockLines :: [Text]
docCommentBlockLines = NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty Text -> [Text]) -> NonEmpty Text -> [Text]
forall a b. (a -> b) -> a -> b
$ ((SourcePos, CommentToken) -> Text)
-> NonEmpty (SourcePos, CommentToken) -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CommentToken -> Text
commentContent (CommentToken -> Text)
-> ((SourcePos, CommentToken) -> CommentToken)
-> (SourcePos, CommentToken)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourcePos, CommentToken) -> CommentToken
forall a b. (a, b) -> b
snd) NonEmpty (SourcePos, CommentToken)
nel
                    , docCommentBlockPos :: SourcePos
docCommentBlockPos = (SourcePos, CommentToken) -> SourcePos
forall a b. (a, b) -> a
fst ((SourcePos, CommentToken) -> SourcePos)
-> (SourcePos, CommentToken) -> SourcePos
forall a b. (a -> b) -> a -> b
$ NonEmpty (SourcePos, CommentToken) -> (SourcePos, CommentToken)
forall a. NonEmpty a -> a
NEL.head NonEmpty (SourcePos, CommentToken)
nel
                    }

parseEntities
    :: PersistSettings
    -> Text
    -> String
    -> ParseResult [EntityBlock]
parseEntities :: PersistSettings -> Text -> String -> ParseResult [EntityBlock]
parseEntities PersistSettings
ps Text
fp String
s = do
    let
        (Set ParserWarning
warnings, Either (ParseErrorBundle String Void) ([EntityBlock], ExtraState)
res) =
            PersistSettings
-> ExtraState
-> Parser [EntityBlock]
-> String
-> String
-> (Set ParserWarning,
    Either (ParseErrorBundle String Void) ([EntityBlock], ExtraState))
forall a.
PersistSettings
-> ExtraState
-> Parser a
-> String
-> String
-> InternalParseResult a
runConfiguredParser PersistSettings
ps ExtraState
initialExtraState Parser [EntityBlock]
entitiesFromDocument (Text -> String
Text.unpack Text
fp) String
s
    case Either (ParseErrorBundle String Void) ([EntityBlock], ExtraState)
res of
        Left ParseErrorBundle String Void
peb ->
            (Set ParserWarning
warnings, ParseErrorBundle String Void
-> Either (ParseErrorBundle String Void) [EntityBlock]
forall a b. a -> Either a b
Left ParseErrorBundle String Void
peb)
        Right ([EntityBlock]
entities, ExtraState
_comments) ->
            (Set ParserWarning
warnings, [EntityBlock]
-> Either (ParseErrorBundle String Void) [EntityBlock]
forall a. a -> Either (ParseErrorBundle String Void) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [EntityBlock]
entities)

toParsedEntityDef :: Maybe SourceLoc -> EntityBlock -> ParsedEntityDef
toParsedEntityDef :: Maybe SourceLoc -> EntityBlock -> ParsedEntityDef
toParsedEntityDef Maybe SourceLoc
mSourceLoc EntityBlock
eb =
    ParsedEntityDef
        { parsedEntityDefComments :: [Text]
parsedEntityDefComments = [Text]
comments
        , parsedEntityDefEntityName :: EntityNameHS
parsedEntityDefEntityName = EntityNameHS
entityNameHS
        , parsedEntityDefIsSum :: Bool
parsedEntityDefIsSum = Bool
isSum
        , parsedEntityDefEntityAttributes :: [Attribute]
parsedEntityDefEntityAttributes = [Attribute]
entityAttributes
        , parsedEntityDefFields :: [(EntityField, Maybe Text)]
parsedEntityDefFields = [(EntityField, Maybe Text)]
parsedFields
        , parsedEntityDefDirectives :: [(Directive, Maybe Text)]
parsedEntityDefDirectives = [(Directive, Maybe Text)]
parsedDirectives
        , parsedEntityDefExtras :: Map Text [[Text]]
parsedEntityDefExtras = Map Text [[Text]]
extras
        , parsedEntityDefSpan :: Maybe SourceSpan
parsedEntityDefSpan = Maybe SourceSpan
mSpan
        }
  where
    comments :: [Text]
comments =
        [Text]
-> (DocCommentBlock -> [Text]) -> Maybe DocCommentBlock -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            []
            DocCommentBlock -> [Text]
docCommentBlockLines
            (EntityBlock -> Maybe DocCommentBlock
entityBlockDocCommentBlock EntityBlock
eb)
    entityAttributes :: [Attribute]
entityAttributes = EntityHeader -> [Attribute]
entityHeaderRemainingAttributes (EntityHeader -> [Attribute])
-> (EntityBlock -> EntityHeader) -> EntityBlock -> [Attribute]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityBlock -> EntityHeader
entityBlockEntityHeader (EntityBlock -> [Attribute]) -> EntityBlock -> [Attribute]
forall a b. (a -> b) -> a -> b
$ EntityBlock
eb
    isSum :: Bool
isSum = EntityHeader -> Bool
entityHeaderSum (EntityHeader -> Bool)
-> (EntityBlock -> EntityHeader) -> EntityBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityBlock -> EntityHeader
entityBlockEntityHeader (EntityBlock -> Bool) -> EntityBlock -> Bool
forall a b. (a -> b) -> a -> b
$ EntityBlock
eb
    entityNameHS :: EntityNameHS
entityNameHS = Text -> EntityNameHS
EntityNameHS (Text -> EntityNameHS)
-> (EntityBlock -> Text) -> EntityBlock -> EntityNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityHeader -> Text
entityHeaderTableName (EntityHeader -> Text)
-> (EntityBlock -> EntityHeader) -> EntityBlock -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityBlock -> EntityHeader
entityBlockEntityHeader (EntityBlock -> EntityNameHS) -> EntityBlock -> EntityNameHS
forall a b. (a -> b) -> a -> b
$ EntityBlock
eb

    fieldPair :: EntityField -> (EntityField, Maybe Text)
fieldPair EntityField
a = (EntityField
a, DocCommentBlock -> Text
docCommentBlockText (DocCommentBlock -> Text) -> Maybe DocCommentBlock -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntityField -> Maybe DocCommentBlock
entityFieldDocCommentBlock EntityField
a)
    parsedFields :: [(EntityField, Maybe Text)]
parsedFields = (EntityField -> (EntityField, Maybe Text))
-> [EntityField] -> [(EntityField, Maybe Text)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EntityField -> (EntityField, Maybe Text)
fieldPair (EntityBlock -> [EntityField]
entityBlockEntityFields EntityBlock
eb)

    directivePair :: Directive -> (Directive, Maybe Text)
directivePair Directive
d = (Directive
d, DocCommentBlock -> Text
docCommentBlockText (DocCommentBlock -> Text) -> Maybe DocCommentBlock -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Directive -> Maybe DocCommentBlock
directiveDocCommentBlock Directive
d)
    parsedDirectives :: [(Directive, Maybe Text)]
parsedDirectives = (Directive -> (Directive, Maybe Text))
-> [Directive] -> [(Directive, Maybe Text)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Directive -> (Directive, Maybe Text)
directivePair (EntityBlock -> [Directive]
entityBlockDirectives EntityBlock
eb)

    extras :: Map Text [[Text]]
extras = [ExtraBlock] -> Map Text [[Text]]
extraBlocksAsMap (EntityBlock -> [ExtraBlock]
entityBlockExtraBlocks EntityBlock
eb)
    filepath :: Text
filepath = Text -> (SourceLoc -> Text) -> Maybe SourceLoc -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" SourceLoc -> Text
locFile Maybe SourceLoc
mSourceLoc
    relativeStartLine :: Int
relativeStartLine = Int -> (SourceLoc -> Int) -> Maybe SourceLoc -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 SourceLoc -> Int
locStartLine Maybe SourceLoc
mSourceLoc
    relativeStartCol :: Int
relativeStartCol = Int -> (SourceLoc -> Int) -> Maybe SourceLoc -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 SourceLoc -> Int
locStartCol Maybe SourceLoc
mSourceLoc
    mSpan :: Maybe SourceSpan
mSpan =
        SourceSpan -> Maybe SourceSpan
forall a. a -> Maybe a
Just
            SourceSpan
                { spanFile :: Text
spanFile = Text
filepath
                , spanStartLine :: Int
spanStartLine =
                    Int
relativeStartLine Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Pos -> Int
unPos (Pos -> Int) -> (SourcePos -> Pos) -> SourcePos -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceLine (SourcePos -> Int) -> SourcePos -> Int
forall a b. (a -> b) -> a -> b
$ EntityBlock -> SourcePos
entityBlockFirstPos EntityBlock
eb)
                , spanEndLine :: Int
spanEndLine = Int
relativeStartLine Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Pos -> Int
unPos (Pos -> Int) -> (SourcePos -> Pos) -> SourcePos -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceLine (SourcePos -> Int) -> SourcePos -> Int
forall a b. (a -> b) -> a -> b
$ EntityBlock -> SourcePos
entityBlockLastPos EntityBlock
eb)
                , spanStartCol :: Int
spanStartCol =
                    Int
relativeStartCol Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Pos -> Int
unPos (Pos -> Int) -> (SourcePos -> Pos) -> SourcePos -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceColumn (SourcePos -> Int) -> SourcePos -> Int
forall a b. (a -> b) -> a -> b
$ EntityBlock -> SourcePos
entityBlockFirstPos EntityBlock
eb)
                , spanEndCol :: Int
spanEndCol = Pos -> Int
unPos (Pos -> Int) -> (SourcePos -> Pos) -> SourcePos -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceColumn (SourcePos -> Int) -> SourcePos -> Int
forall a b. (a -> b) -> a -> b
$ EntityBlock -> SourcePos
entityBlockLastPos EntityBlock
eb
                }

parseSource
    :: PersistSettings
    -> Maybe SourceLoc
    -> Text
    -> ParseResult [ParsedEntityDef]
parseSource :: PersistSettings
-> Maybe SourceLoc -> Text -> ParseResult [ParsedEntityDef]
parseSource PersistSettings
ps Maybe SourceLoc
mSourceLoc Text
source =
    ([EntityBlock] -> [ParsedEntityDef])
-> Either (ParseErrorBundle String Void) [EntityBlock]
-> Either (ParseErrorBundle String Void) [ParsedEntityDef]
forall a b.
(a -> b)
-> Either (ParseErrorBundle String Void) a
-> Either (ParseErrorBundle String Void) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((EntityBlock -> ParsedEntityDef)
-> [EntityBlock] -> [ParsedEntityDef]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe SourceLoc -> EntityBlock -> ParsedEntityDef
toParsedEntityDef Maybe SourceLoc
mSourceLoc))
        (Either (ParseErrorBundle String Void) [EntityBlock]
 -> Either (ParseErrorBundle String Void) [ParsedEntityDef])
-> ParseResult [EntityBlock] -> ParseResult [ParsedEntityDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistSettings -> Text -> String -> ParseResult [EntityBlock]
parseEntities PersistSettings
ps Text
filepath (Text -> String
Text.unpack Text
source)
  where
    filepath :: Text
filepath = Text -> (SourceLoc -> Text) -> Maybe SourceLoc -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" SourceLoc -> Text
locFile Maybe SourceLoc
mSourceLoc