    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE TupleSections #-}

    -- | Parser for fixity maps.
    module Ormolu.Fixity.Parser
      ( parseFixityMap,
        parseFixityDeclaration,

        -- * Raw parsers
        pFixity,
        pOperator,
      )
    where

    import qualified Data.Char as Char
    import qualified Data.Map.Strict as Map
    import Data.Text (Text)
    import qualified Data.Text as T
    import Data.Void (Void)
    import Ormolu.Fixity
    import Text.Megaparsec
    import Text.Megaparsec.Char
    import qualified Text.Megaparsec.Char.Lexer as L

    type Parser = Parsec Void Text

    -- | Parse textual representation of a 'FixityMap'.
    parseFixityMap ::
      -- | Location of the file we are parsing (only for parse errors)
      FilePath ->
      -- | File contents to parse
      Text ->
      -- | Parse result
      Either (ParseErrorBundle Text Void) FixityMap
    parseFixityMap :: FilePath -> Text -> Either (ParseErrorBundle Text Void) FixityMap
    parseFixityMap = Parsec Void Text FixityMap
    -> FilePath
    -> Text
    -> Either (ParseErrorBundle Text Void) FixityMap
    forall e s a.
    Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
    runParser Parsec Void Text FixityMap
    pFixityMap

    -- | Parse a single self-contained fixity declaration.
    parseFixityDeclaration ::
      -- | Expression to parse
      Text ->
      -- | Parse result
      Either (ParseErrorBundle Text Void) [(OpName, FixityInfo)]
    parseFixityDeclaration :: Text -> Either (ParseErrorBundle Text Void) [(OpName, FixityInfo)]
    parseFixityDeclaration = Parsec Void Text [(OpName, FixityInfo)]
    -> FilePath
    -> Text
    -> Either (ParseErrorBundle Text Void) [(OpName, FixityInfo)]
    forall e s a.
    Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
    runParser (Parsec Void Text [(OpName, FixityInfo)]
    pFixity Parsec Void Text [(OpName, FixityInfo)]
    -> ParsecT Void Text Identity ()
    -> Parsec Void Text [(OpName, FixityInfo)]
    forall a b.
    ParsecT Void Text Identity a
    -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* ParsecT Void Text Identity ()
    forall e s (m :: * -> *). MonadParsec e s m => m ()
    eof) FilePath
    ""

    pFixityMap :: Parser FixityMap
    pFixityMap :: Parsec Void Text FixityMap
    pFixityMap =
      (FixityInfo -> FixityInfo -> FixityInfo)
    -> [(OpName, FixityInfo)] -> FixityMap
    forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
    Map.fromListWith FixityInfo -> FixityInfo -> FixityInfo
    forall a. Semigroup a => a -> a -> a
    (<>) ([(OpName, FixityInfo)] -> FixityMap)
    -> ([[(OpName, FixityInfo)]] -> [(OpName, FixityInfo)])
    -> [[(OpName, FixityInfo)]]
    -> FixityMap
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [[(OpName, FixityInfo)]] -> [(OpName, FixityInfo)]
    forall a. Monoid a => [a] -> a
    mconcat
        ([[(OpName, FixityInfo)]] -> FixityMap)
    -> ParsecT Void Text Identity [[(OpName, FixityInfo)]]
    -> Parsec Void Text FixityMap
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Parsec Void Text [(OpName, FixityInfo)]
    -> ParsecT Void Text Identity [[(OpName, FixityInfo)]]
    forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
    many (Parsec Void Text [(OpName, FixityInfo)]
    pFixity Parsec Void Text [(OpName, FixityInfo)]
    -> ParsecT Void Text Identity (Tokens Text)
    -> Parsec Void Text [(OpName, FixityInfo)]
    forall a b.
    ParsecT Void Text Identity a
    -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* ParsecT Void Text Identity (Tokens Text)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m (Tokens s)
    eol Parsec Void Text [(OpName, FixityInfo)]
    -> ParsecT Void Text Identity ()
    -> Parsec Void Text [(OpName, FixityInfo)]
    forall a b.
    ParsecT Void Text Identity a
    -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
    forall a.
    ParsecT Void Text Identity a -> ParsecT Void Text Identity a
    forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
    hidden ParsecT Void Text Identity ()
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m ()
    space)
        Parsec Void Text FixityMap
    -> ParsecT Void Text Identity () -> Parsec Void Text FixityMap
    forall a b.
    ParsecT Void Text Identity a
    -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* ParsecT Void Text Identity ()
    forall e s (m :: * -> *). MonadParsec e s m => m ()
    eof

    -- | Parse a single fixity declaration, such as
    --
    -- > infixr 4 +++, >>>
    pFixity :: Parser [(OpName, FixityInfo)]
    pFixity :: Parsec Void Text [(OpName, FixityInfo)]
    pFixity = do
      Maybe FixityDirection
    fiDirection <- FixityDirection -> Maybe FixityDirection
    forall a. a -> Maybe a
    Just (FixityDirection -> Maybe FixityDirection)
    -> ParsecT Void Text Identity FixityDirection
    -> ParsecT Void Text Identity (Maybe FixityDirection)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ParsecT Void Text Identity FixityDirection
    pFixityDirection
      ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
    forall a.
    ParsecT Void Text Identity a -> ParsecT Void Text Identity a
    forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
    hidden ParsecT Void Text Identity ()
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m ()
    hspace1
      Int
    fiMinPrecedence <- ParsecT Void Text Identity Int
    forall e s (m :: * -> *) a.
    (MonadParsec e s m, Token s ~ Char, Num a) =>
    m a
    L.decimal
      let fiMaxPrecedence :: Int
    fiMaxPrecedence = Int
    fiMinPrecedence
      ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
    forall a.
    ParsecT Void Text Identity a -> ParsecT Void Text Identity a
    forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
    hidden ParsecT Void Text Identity ()
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m ()
    hspace1
      [OpName]
    ops <- ParsecT Void Text Identity OpName
    -> ParsecT Void Text Identity ()
    -> ParsecT Void Text Identity [OpName]
    forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
    sepBy1 ParsecT Void Text Identity OpName
    pOperator (Token Text -> ParsecT Void Text Identity (Token Text)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    Token s -> m (Token s)
    char Char
    Token Text
    ',' ParsecT Void Text Identity Char
    -> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
    forall a b.
    ParsecT Void Text Identity a
    -> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
    forall a.
    ParsecT Void Text Identity a -> ParsecT Void Text Identity a
    forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
    hidden ParsecT Void Text Identity ()
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m ()
    hspace)
      ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
    forall a.
    ParsecT Void Text Identity a -> ParsecT Void Text Identity a
    forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
    hidden ParsecT Void Text Identity ()
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m ()
    hspace
      let fixityInfo :: FixityInfo
    fixityInfo = FixityInfo {Int
    Maybe FixityDirection
    fiDirection :: Maybe FixityDirection
    fiMinPrecedence :: Int
    fiMaxPrecedence :: Int
    fiDirection :: Maybe FixityDirection
    fiMinPrecedence :: Int
    fiMaxPrecedence :: Int
    ..}
      [(OpName, FixityInfo)] -> Parsec Void Text [(OpName, FixityInfo)]
    forall a. a -> ParsecT Void Text Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((,FixityInfo
    fixityInfo) (OpName -> (OpName, FixityInfo))
    -> [OpName] -> [(OpName, FixityInfo)]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [OpName]
    ops)

    pFixityDirection :: Parser FixityDirection
    pFixityDirection :: ParsecT Void Text Identity FixityDirection
    pFixityDirection =
      [ParsecT Void Text Identity FixityDirection]
    -> ParsecT Void Text Identity FixityDirection
    forall (f :: * -> *) (m :: * -> *) a.
    (Foldable f, Alternative m) =>
    f (m a) -> m a
    choice
        [ FixityDirection
    InfixL FixityDirection
    -> ParsecT Void Text Identity (Tokens Text)
    -> ParsecT Void Text Identity FixityDirection
    forall a b.
    a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
    forall e s (m :: * -> *).
    MonadParsec e s m =>
    Tokens s -> m (Tokens s)
    string Tokens Text
    "infixl",
          FixityDirection
    InfixR FixityDirection
    -> ParsecT Void Text Identity (Tokens Text)
    -> ParsecT Void Text Identity FixityDirection
    forall a b.
    a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
    forall e s (m :: * -> *).
    MonadParsec e s m =>
    Tokens s -> m (Tokens s)
    string Tokens Text
    "infixr",
          FixityDirection
    InfixN FixityDirection
    -> ParsecT Void Text Identity (Tokens Text)
    -> ParsecT Void Text Identity FixityDirection
    forall a b.
    a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
    forall e s (m :: * -> *).
    MonadParsec e s m =>
    Tokens s -> m (Tokens s)
    string Tokens Text
    "infix"
        ]

    -- | See <https://www.haskell.org/onlinereport/haskell2010/haskellch2.html>
    pOperator :: Parser OpName
    pOperator :: ParsecT Void Text Identity OpName
    pOperator = Text -> OpName
    OpName (Text -> OpName)
    -> ParsecT Void Text Identity Text
    -> ParsecT Void Text Identity OpName
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (ParsecT Void Text Identity Text
    tickedOperator ParsecT Void Text Identity Text
    -> ParsecT Void Text Identity Text
    -> ParsecT Void Text Identity Text
    forall a.
    ParsecT Void Text Identity a
    -> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> ParsecT Void Text Identity (Tokens Text)
    ParsecT Void Text Identity Text
    normalOperator)
      where
        tickedOperator :: ParsecT Void Text Identity Text
    tickedOperator = ParsecT Void Text Identity (Token Text)
    -> ParsecT Void Text Identity (Token Text)
    -> ParsecT Void Text Identity Text
    -> ParsecT Void Text Identity Text
    forall (m :: * -> *) open close a.
    Applicative m =>
    m open -> m close -> m a -> m a
    between ParsecT Void Text Identity (Token Text)
    tick ParsecT Void Text Identity (Token Text)
    tick ParsecT Void Text Identity Text
    haskellIdentifier
        tick :: ParsecT Void Text Identity (Token Text)
    tick = Token Text -> ParsecT Void Text Identity (Token Text)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    Token s -> m (Token s)
    char Char
    Token Text
    '`'
        haskellIdentifier :: ParsecT Void Text Identity Text
    haskellIdentifier =
          Char -> Text -> Text
    T.cons
            (Char -> Text -> Text)
    -> ParsecT Void Text Identity Char
    -> ParsecT Void Text Identity (Text -> Text)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ParsecT Void Text Identity Char
    ParsecT Void Text Identity (Token Text)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m (Token s)
    letterChar
            ParsecT Void Text Identity (Text -> Text)
    -> ParsecT Void Text Identity Text
    -> ParsecT Void Text Identity Text
    forall a b.
    ParsecT Void Text Identity (a -> b)
    -> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Maybe FilePath
    -> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
    forall e s (m :: * -> *).
    MonadParsec e s m =>
    Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
    takeWhileP Maybe FilePath
    forall a. Maybe a
    Nothing (\Token Text
    x -> Char -> Bool
    Char.isAlphaNum Char
    Token Text
    x Bool -> Bool -> Bool
    || Char
    Token Text
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '_' Bool -> Bool -> Bool
    || Char
    Token Text
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\'')
        normalOperator :: ParsecT Void Text Identity (Tokens Text)
    normalOperator =
          Maybe FilePath
    -> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
    forall e s (m :: * -> *).
    MonadParsec e s m =>
    Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
    takeWhile1P (FilePath -> Maybe FilePath
    forall a. a -> Maybe a
    Just FilePath
    "operator character") ((Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text))
    -> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
    forall a b. (a -> b) -> a -> b
    $ \Token Text
    x ->
            (Char -> Bool
    Char.isSymbol Char
    Token Text
    x Bool -> Bool -> Bool
    || Char -> Bool
    Char.isPunctuation Char
    Token Text
    x)
              Bool -> Bool -> Bool
    && (Char
    Token Text
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    ',' Bool -> Bool -> Bool
    && Char
    Token Text
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '`' Bool -> Bool -> Bool
    && Char
    Token Text
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '(' Bool -> Bool -> Bool
    && Char
    Token Text
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    ')')