{-# 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 Text
ParsecT Void Text Identity (Tokens 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
')')