{-# 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 :: String -> Text -> Either (ParseErrorBundle Text Void) FixityMap
parseFixityMap = forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser Parser 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) [(String, FixityInfo)]
parseFixityDeclaration = forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (ParsecT Void Text Identity [(String, FixityInfo)]
pFixity forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
""

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

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

pFixityDirection :: Parser FixityDirection
pFixityDirection :: Parser FixityDirection
pFixityDirection =
  forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ FixityDirection
InfixL forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"infixl",
      FixityDirection
InfixR forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"infixr",
      FixityDirection
InfixN forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 :: Parser String
pOperator = ParsecT Void Text Identity [Token Text]
tickedOperator forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity [Token Text]
normalOperator
  where
    tickedOperator :: ParsecT Void Text Identity [Token Text]
tickedOperator = 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 [Token Text]
haskellIdentifier
    tick :: ParsecT Void Text Identity (Token Text)
tick = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'`'
    haskellIdentifier :: ParsecT Void Text Identity [Token Text]
haskellIdentifier = do
      Token Text
x <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar
      [Token Text]
xs <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'_' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\'')
      forall (m :: * -> *) a. Monad m => a -> m a
return (Token Text
x forall a. a -> [a] -> [a]
: [Token Text]
xs)
    normalOperator :: ParsecT Void Text Identity [Token Text]
normalOperator = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Text Identity (Token Text)
operatorChar
    operatorChar :: ParsecT Void Text Identity (Token Text)
operatorChar =
      forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy
        (\Token Text
x -> (Char -> Bool
Char.isSymbol Token Text
x Bool -> Bool -> Bool
|| Char -> Bool
Char.isPunctuation Token Text
x) Bool -> Bool -> Bool
&& Token Text
x forall a. Eq a => a -> a -> Bool
/= Char
',' Bool -> Bool -> Bool
&& Token Text
x forall a. Eq a => a -> a -> Bool
/= Char
'`')
        forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"operator character"