{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
module Database.Persist.Quasi.Internal.ModelParser
( SourceLoc (..)
, Token (..)
, tokenContent
, anyToken
, ParsedEntityDef
, parsedEntityDefComments
, parsedEntityDefEntityName
, parsedEntityDefIsSum
, parsedEntityDefEntityAttributes
, parsedEntityDefFieldAttributes
, parsedEntityDefExtras
, parsedEntityDefSpan
, parseSource
, memberBlockAttrs
, ParserWarning
, parserWarningMessage
, ParseResult
, CumulativeParseResult
, toCumulativeParseResult
, renderErrors
, runConfiguredParser
, ParserErrorLevel (..)
, initialExtraState
) where
import Control.Applicative (Alternative)
import Control.Monad (MonadPlus, mzero, 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 (find, 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.PersistSettings.Internal
import Database.Persist.Types
import Database.Persist.Types.SourceSpan
import Language.Haskell.TH.Syntax (Lift)
import Text.Megaparsec hiding (Token)
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import qualified Text.Megaparsec.Stream as TMS
data =
{ :: [(SourcePos, CommentToken)]
, ExtraState -> Maybe SourcePos
esLastDocumentablePosition :: Maybe SourcePos
}
initialExtraState :: ExtraState
=
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
)
type EntityParseError = ParseErrorBundle String Void
type ParseResult a =
(Set ParserWarning, Either (ParseErrorBundle String Void) a)
type InternalParseResult a = ParseResult (a, ExtraState)
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)
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
,
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
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
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
parserState <- Parser (State String Void)
forall e s (m :: * -> *). MonadParsec e s m => m (State s e)
getParserState
withRecovery (warnAndRetry $ statePosState parserState) 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
tryOrRegisterError
:: String
-> (ParseError String Void -> Bool)
-> Parser a
-> Parser a
-> Parser a
tryOrRegisterError :: forall a.
String
-> (ParseError String Void -> Bool)
-> Parser a
-> Parser a
-> Parser a
tryOrRegisterError String
msg ParseError String Void -> Bool
p Parser a
l Parser a
r = do
parserState <- Parser (State String Void)
forall e s (m :: * -> *). MonadParsec e s m => m (State s e)
getParserState
withRecovery (delayedError $ statePosState parserState) 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 -> String
-> (ParseError String Void -> Bool)
-> Parser a
-> Parser a
-> Parser a
forall a.
String
-> (ParseError String Void -> Bool)
-> Parser a
-> Parser a
-> Parser a
tryOrRegisterError String
msg 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
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)
data Token
= Quotation Text
| Equality Text Text
| Parenthetical Text
| BlockKey Text
| PText Text
deriving (Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: Token -> Token -> Bool
Eq, Eq Token
Eq Token =>
(Token -> Token -> Ordering)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Token)
-> (Token -> Token -> Token)
-> Ord Token
Token -> Token -> Bool
Token -> Token -> Ordering
Token -> Token -> Token
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 :: Token -> Token -> Ordering
compare :: Token -> Token -> Ordering
$c< :: Token -> Token -> Bool
< :: Token -> Token -> Bool
$c<= :: Token -> Token -> Bool
<= :: Token -> Token -> Bool
$c> :: Token -> Token -> Bool
> :: Token -> Token -> Bool
$c>= :: Token -> Token -> Bool
>= :: Token -> Token -> Bool
$cmax :: Token -> Token -> Token
max :: Token -> Token -> Token
$cmin :: Token -> Token -> Token
min :: Token -> Token -> Token
Ord, Int -> Token -> String -> String
[Token] -> String -> String
Token -> String
(Int -> Token -> String -> String)
-> (Token -> String) -> ([Token] -> String -> String) -> Show Token
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Token -> String -> String
showsPrec :: Int -> Token -> String -> String
$cshow :: Token -> String
show :: Token -> String
$cshowList :: [Token] -> String -> String
showList :: [Token] -> String -> String
Show)
data
= Text
| 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)
tokenContent :: Token -> Text
tokenContent :: Token -> Text
tokenContent = \case
Quotation Text
s -> Text
s
Equality 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
BlockKey Text
s -> Text
s
commentContent :: CommentToken -> Text
= \case
Comment Text
s -> Text
s
DocComment Text
s -> Text
s
docComment :: Parser (SourcePos, CommentToken)
= do
pos <- Parser SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
content <-
string "-- |" *> validHSpace *> takeWhileP (Just "character") (/= '\n')
pure (pos, DocComment (Text.pack content))
comment :: Parser (SourcePos, CommentToken)
= do
pos <- Parser SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
content <-
(string "--" <|> string "#")
*> validHSpace
*> takeWhileP (Just "character") (/= '\n')
pure (pos, Comment (Text.pack content))
skipComment :: Parser ()
= do
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
void $ appendCommentToState 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
tabErrorLevel <- (PersistSettings -> Maybe ParserErrorLevel)
-> Parser (Maybe ParserErrorLevel)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PersistSettings -> Maybe ParserErrorLevel
psTabErrorLevel
void $
tryOrReport
tabErrorLevel
"use spaces instead of tabs"
isUnexpectedTabError
(taker (Just "valid whitespace") (validator False))
(taker (Just "valid whitespace") (validator 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
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
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
'\\'
nextChar <- lookAhead anySingle
if nextChar == '(' || nextChar == ')'
then single nextChar
else pure 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']
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
char1 <- Parser Char
Parser (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
case char1 of
Char
'\\' -> do
char2 <- Parser Char
Parser (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
case 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
equality :: Parser Token
equality :: Parser Token
equality = String -> Parser Token -> Parser Token
forall a. String -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"equality expression" (Parser Token -> Parser Token) -> Parser Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ do
Parser () -> Parser Token -> Parser Token
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer (Parser Token -> Parser Token) -> Parser Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ do
lhs <- Parser Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser Char
contentChar
_ <- char '='
rhs <-
choice
[ quotation'
, sqlLiteral
, parentheticalInner
, some $ contentChar <|> char '(' <|> char ')'
]
pure $ Equality (Text.pack lhs) (Text.pack rhs)
where
parentheticalInner :: Parser String
parentheticalInner = do
str <- Parser String
parenthetical'
pure . init . drop 1 $ str
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
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
'\'')
st <- optional $ do
colons <- string "::"
tn <- sqlTypeName
pure $ colons <> tn
pure $
mconcat
[ "'"
, quote
, "'"
, fromMaybe "" st
]
quotation :: Parser Token
quotation :: Parser Token
quotation = String -> Parser Token -> Parser Token
forall a. String -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"quotation" (Parser Token -> Parser Token) -> Parser Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ do
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
quotation'
pure . Quotation $ Text.pack str
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 Token
parenthetical :: Parser Token
parenthetical = String -> Parser Token -> Parser Token
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 Token -> Parser Token) -> Parser Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ do
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'
pure . Parenthetical . Text.pack . init . drop 1 $ str
parenthetical' :: Parser String
parenthetical' :: Parser String
parenthetical' = do
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
pure $ "(" ++ str ++ ")"
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 Token
blockKey :: Parser Token
blockKey = String -> Parser Token -> Parser Token
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 Token -> Parser Token) -> Parser Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ do
fl <- Parser Char
Parser (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar
rl <- many alphaNumChar
pure . BlockKey . Text.pack $ fl : rl
ptext :: Parser Token
ptext :: Parser Token
ptext = String -> Parser Token -> Parser Token
forall a. String -> Parser a -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"plain token" (Parser Token -> Parser Token) -> Parser Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ do
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
pure . PText . Text.pack $ str
anyToken :: Parser Token
anyToken :: Parser Token
anyToken =
[Parser Token] -> Parser Token
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ Parser Token -> Parser Token
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Token
equality
, Parser Token
quotation
, Parser Token
parenthetical
, Parser Token
ptext
]
data ParsedEntityDef = ParsedEntityDef
{ :: [Text]
, ParsedEntityDef -> EntityNameHS
parsedEntityDefEntityName :: EntityNameHS
, ParsedEntityDef -> Bool
parsedEntityDefIsSum :: Bool
, ParsedEntityDef -> [Text]
parsedEntityDefEntityAttributes :: [Attr]
, ParsedEntityDef -> [([Token], Maybe Text)]
parsedEntityDefFieldAttributes :: [([Token], Maybe Text)]
, :: 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 =
{ :: [Text]
, :: 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 =
{ :: Bool
, :: Text
, EntityHeader -> [Token]
entityHeaderRemainingTokens :: [Token]
, :: 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
{ :: Maybe DocCommentBlock
, :: 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
entityBlockBlockAttrs :: EntityBlock -> [BlockAttr]
entityBlockBlockAttrs :: EntityBlock -> [BlockAttr]
entityBlockBlockAttrs = (Member -> [BlockAttr]) -> [Member] -> [BlockAttr]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Member -> [BlockAttr]
f ([Member] -> [BlockAttr])
-> (EntityBlock -> [Member]) -> EntityBlock -> [BlockAttr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntityBlock -> [Member]
entityBlockMembers
where
f :: Member -> [BlockAttr]
f Member
m = case Member
m of
MemberExtraBlock ExtraBlock
_ -> []
MemberBlockAttr BlockAttr
ba -> [BlockAttr
ba]
entityBlockExtraBlocks :: EntityBlock -> [ExtraBlock]
= (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]
MemberBlockAttr BlockAttr
_ -> []
data =
{ :: Text
, ExtraBlockHeader -> [Token]
extraBlockHeaderRemainingTokens :: [Token]
, :: 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 =
{ :: Maybe DocCommentBlock
, :: ExtraBlockHeader
, :: NonEmpty Member
}
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 BlockAttr = BlockAttr
{ :: Maybe DocCommentBlock
, BlockAttr -> [Token]
blockAttrTokens :: [Token]
, BlockAttr -> SourcePos
blockAttrPos :: SourcePos
}
deriving (Int -> BlockAttr -> String -> String
[BlockAttr] -> String -> String
BlockAttr -> String
(Int -> BlockAttr -> String -> String)
-> (BlockAttr -> String)
-> ([BlockAttr] -> String -> String)
-> Show BlockAttr
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> BlockAttr -> String -> String
showsPrec :: Int -> BlockAttr -> String -> String
$cshow :: BlockAttr -> String
show :: BlockAttr -> String
$cshowList :: [BlockAttr] -> String -> String
showList :: [BlockAttr] -> String -> String
Show)
data Member = ExtraBlock | MemberBlockAttr BlockAttr
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)
memberEndPos :: Member -> SourcePos
memberEndPos :: Member -> SourcePos
memberEndPos (MemberBlockAttr BlockAttr
fs) = BlockAttr -> SourcePos
blockAttrPos BlockAttr
fs
memberEndPos (MemberExtraBlock ExtraBlock
ex) = Member -> SourcePos
memberEndPos (Member -> SourcePos)
-> (ExtraBlock -> Member) -> ExtraBlock -> SourcePos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Member -> Member
forall a. NonEmpty a -> a
NEL.last (NonEmpty Member -> Member)
-> (ExtraBlock -> NonEmpty Member) -> ExtraBlock -> Member
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtraBlock -> NonEmpty Member
extraBlockMembers (ExtraBlock -> SourcePos) -> ExtraBlock -> SourcePos
forall a b. (a -> b) -> a -> b
$ ExtraBlock
ex
memberBlockAttrs :: Member -> [BlockAttr]
memberBlockAttrs :: Member -> [BlockAttr]
memberBlockAttrs (MemberBlockAttr BlockAttr
fs) = [BlockAttr
fs]
memberBlockAttrs (MemberExtraBlock ExtraBlock
ex) = (Member -> [BlockAttr]) -> NonEmpty Member -> [BlockAttr]
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Member -> [BlockAttr]
memberBlockAttrs (NonEmpty Member -> [BlockAttr])
-> (ExtraBlock -> NonEmpty Member) -> ExtraBlock -> [BlockAttr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtraBlock -> NonEmpty Member
extraBlockMembers (ExtraBlock -> [BlockAttr]) -> ExtraBlock -> [BlockAttr]
forall a b. (a -> b) -> a -> b
$ ExtraBlock
ex
extraBlocksAsMap :: [ExtraBlock] -> M.Map Text [ExtraLine]
[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, ExtraBlock -> [[Text]]
extraLines ExtraBlock
ex)
extraLines :: ExtraBlock -> [[Text]]
extraLines ExtraBlock
ex = (Member -> [[Text]]) -> NonEmpty Member -> [[Text]]
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Member -> [[Text]]
asExtraLine (ExtraBlock -> NonEmpty Member
extraBlockMembers ExtraBlock
ex)
asExtraLine :: Member -> [[Text]]
asExtraLine (MemberBlockAttr BlockAttr
fs) = [Token -> Text
tokenContent (Token -> Text) -> [Token] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockAttr -> [Token]
blockAttrTokens BlockAttr
fs]
asExtraLine Member
_ = []
entityHeader :: Parser EntityHeader
= do
pos <- Parser SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
plus <- optional (char '+')
en <- validHSpace *> L.lexeme spaceConsumer blockKey
rest <- L.lexeme spaceConsumer (many anyToken)
_ <- setLastDocumentablePosition
pure
EntityHeader
{ entityHeaderSum = isJust plus
, entityHeaderTableName = tokenContent en
, entityHeaderRemainingTokens = rest
, entityHeaderPos = pos
}
appendCommentToState :: (SourcePos, CommentToken) -> Parser ()
(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
pos <- Parser SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
modify $ \ExtraState
es -> ExtraState
es{esLastDocumentablePosition = Just pos}
getDcb :: Parser (Maybe DocCommentBlock)
getDcb :: Parser (Maybe DocCommentBlock)
getDcb = do
es <- Parser ExtraState
forall s (m :: * -> *). MonadState s m => m s
get
let
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
_ <- put es{esPositionedCommentTokens = []}
let
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) -> Bool)
-> [(SourcePos, CommentToken)] -> [(SourcePos, CommentToken)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (ExtraState -> (SourcePos, CommentToken) -> Bool
commentIsIncorrectlyPositioned ExtraState
es) [(SourcePos, CommentToken)]
candidates
pure $ docCommentBlockFromPositionedTokens 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
= Parser ()
-> Parser (IndentOpt Parser Member Member) -> 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 Member)
innerParser
where
mkExtraBlockMember :: Maybe DocCommentBlock -> (ExtraBlockHeader, [Member]) -> Member
mkExtraBlockMember Maybe DocCommentBlock
dcb (ExtraBlockHeader
header, [Member]
blockAttrs) =
ExtraBlock -> Member
MemberExtraBlock
ExtraBlock
{ extraBlockExtraBlockHeader :: ExtraBlockHeader
extraBlockExtraBlockHeader = ExtraBlockHeader
header
, extraBlockMembers :: NonEmpty Member
extraBlockMembers = [Member] -> NonEmpty Member
forall {a}. [a] -> NonEmpty a
ensureNonEmpty [Member]
blockAttrs
, extraBlockDocCommentBlock :: Maybe DocCommentBlock
extraBlockDocCommentBlock = Maybe DocCommentBlock
dcb
}
ensureNonEmpty :: [a] -> NonEmpty a
ensureNonEmpty [a]
members = case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [a]
members of
Just NonEmpty a
nel -> NonEmpty a
nel
Maybe (NonEmpty a)
Nothing -> String -> NonEmpty a
forall a. HasCallStack => String -> a
error String
"unreachable"
innerParser :: Parser (IndentOpt Parser Member Member)
innerParser = do
dcb <- Parser (Maybe DocCommentBlock)
getDcb
header <- extraBlockHeader
pure $
L.IndentSome Nothing (return . mkExtraBlockMember dcb . (header,)) blockAttr
extraBlockHeader :: Parser ExtraBlockHeader
= do
pos <- Parser SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
tn <- L.lexeme spaceConsumer blockKey
rest <- L.lexeme spaceConsumer (many anyToken)
_ <- setLastDocumentablePosition
pure $
ExtraBlockHeader
{ extraBlockHeaderKey = tokenContent tn
, extraBlockHeaderRemainingTokens = rest
, extraBlockHeaderPos = pos
}
blockAttr :: Parser Member
blockAttr :: Parser Member
blockAttr = do
dcb <- Parser (Maybe DocCommentBlock)
getDcb
pos <- getSourcePos
line <- some anyToken
_ <- setLastDocumentablePosition
pure $
MemberBlockAttr
BlockAttr
{ blockAttrDocCommentBlock = dcb
, blockAttrTokens = line
, blockAttrPos = pos
}
member :: Parser Member
member :: Parser Member
member = 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 -> Parser Member -> Parser Member
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Member
blockAttr
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
dcb <- Parser (Maybe DocCommentBlock)
getDcb
header <- entityHeader
pure $ L.IndentMany Nothing (return . mkEntityBlock dcb . (header,)) 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
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
CommentToken
tok = case CommentToken
tok of
DocComment Text
_ -> Bool
True
CommentToken
_ -> Bool
False
docCommentBlockFromPositionedTokens
:: [(SourcePos, CommentToken)] -> Maybe DocCommentBlock
[(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 :: [Text]
parsedEntityDefEntityAttributes = [Text]
entityAttributes
, parsedEntityDefFieldAttributes :: [([Token], Maybe Text)]
parsedEntityDefFieldAttributes = [([Token], Maybe Text)]
parsedFieldAttributes
, 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 :: [Text]
entityAttributes =
Token -> Text
tokenContent (Token -> Text) -> [Token] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EntityHeader -> [Token]
entityHeaderRemainingTokens (EntityHeader -> [Token])
-> (EntityBlock -> EntityHeader) -> EntityBlock -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityBlock -> EntityHeader
entityBlockEntityHeader) 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
attributePair :: BlockAttr -> ([Token], Maybe Text)
attributePair BlockAttr
a = (BlockAttr -> [Token]
blockAttrTokens BlockAttr
a, DocCommentBlock -> Text
docCommentBlockText (DocCommentBlock -> Text) -> Maybe DocCommentBlock -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockAttr -> Maybe DocCommentBlock
blockAttrDocCommentBlock BlockAttr
a)
parsedFieldAttributes :: [([Token], Maybe Text)]
parsedFieldAttributes = (BlockAttr -> ([Token], Maybe Text))
-> [BlockAttr] -> [([Token], Maybe Text)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockAttr -> ([Token], Maybe Text)
attributePair (EntityBlock -> [BlockAttr]
entityBlockBlockAttrs 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