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

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

import qualified Data.Char as Char
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import Data.Void (Void)
import Ormolu.Fixity.Internal
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) [(String, FixityInfo)]
parseFixityDeclaration :: Text
-> Either (ParseErrorBundle Text Void) [(FilePath, FixityInfo)]
parseFixityDeclaration = Parsec Void Text [(FilePath, FixityInfo)]
-> FilePath
-> Text
-> Either (ParseErrorBundle Text Void) [(FilePath, FixityInfo)]
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec Void Text [(FilePath, FixityInfo)]
pFixity Parsec Void Text [(FilePath, FixityInfo)]
-> ParsecT Void Text Identity ()
-> Parsec Void Text [(FilePath, FixityInfo)]
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)
-> [(FilePath, 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
(<>) ([(FilePath, FixityInfo)] -> FixityMap)
-> ([[(FilePath, FixityInfo)]] -> [(FilePath, FixityInfo)])
-> [[(FilePath, FixityInfo)]]
-> FixityMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(FilePath, FixityInfo)]] -> [(FilePath, FixityInfo)]
forall a. Monoid a => [a] -> a
mconcat
    ([[(FilePath, FixityInfo)]] -> FixityMap)
-> ParsecT Void Text Identity [[(FilePath, FixityInfo)]]
-> Parsec Void Text FixityMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text [(FilePath, FixityInfo)]
-> ParsecT Void Text Identity [[(FilePath, FixityInfo)]]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Parsec Void Text [(FilePath, FixityInfo)]
pFixity Parsec Void Text [(FilePath, FixityInfo)]
-> ParsecT Void Text Identity Char
-> Parsec Void Text [(FilePath, FixityInfo)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline Parsec Void Text [(FilePath, FixityInfo)]
-> ParsecT Void Text Identity ()
-> Parsec Void Text [(FilePath, FixityInfo)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
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 (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

pFixity :: Parser [(String, FixityInfo)]
pFixity :: Parsec Void Text [(FilePath, 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 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 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
  [FilePath]
ops <- ParsecT Void Text Identity FilePath
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity [FilePath]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 ParsecT Void Text Identity FilePath
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
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 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 :: Maybe FixityDirection -> Int -> Int -> FixityInfo
FixityInfo {Int
Maybe FixityDirection
fiMaxPrecedence :: Int
fiMinPrecedence :: Int
fiDirection :: Maybe FixityDirection
fiMaxPrecedence :: Int
fiMinPrecedence :: Int
fiDirection :: Maybe FixityDirection
..}
  [(FilePath, FixityInfo)]
-> Parsec Void Text [(FilePath, FixityInfo)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((,FixityInfo
fixityInfo) (FilePath -> (FilePath, FixityInfo))
-> [FilePath] -> [(FilePath, FixityInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
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 Text
-> ParsecT Void Text Identity FixityDirection
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 Text
-> ParsecT Void Text Identity FixityDirection
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 Text
-> ParsecT Void Text Identity FixityDirection
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 String
pOperator :: ParsecT Void Text Identity FilePath
pOperator = ParsecT Void Text Identity FilePath
tickedOperator ParsecT Void Text Identity FilePath
-> ParsecT Void Text Identity FilePath
-> ParsecT Void Text Identity FilePath
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity FilePath
normalOperator
  where
    tickedOperator :: ParsecT Void Text Identity FilePath
tickedOperator = ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity FilePath
-> ParsecT Void Text Identity FilePath
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 FilePath
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 FilePath
haskellIdentifier = do
      Char
x <- ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar
      FilePath
xs <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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 Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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
'\'')
      FilePath -> ParsecT Void Text Identity FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
x Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
xs)
    normalOperator :: ParsecT Void Text Identity FilePath
normalOperator = ParsecT Void Text Identity Char
-> ParsecT Void Text Identity FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Text Identity Char
operatorChar
    operatorChar :: ParsecT Void Text Identity Char
operatorChar =
      (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy
        (\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
'`')
        ParsecT Void Text Identity Char
-> FilePath -> ParsecT Void Text Identity Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> FilePath -> m a
<?> FilePath
"operator character"