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

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 [(OpName, 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 (Tokens s)
eol 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

-- | Parse a single fixity declaration, such as
--
-- > infixr 4 +++, >>>
pFixity :: Parser [(OpName, FixityInfo)]
pFixity :: ParsecT Void Text Identity [(OpName, 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
  [OpName]
ops <- forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 Parser OpName
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
<$> [OpName]
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 OpName
pOperator :: Parser OpName
pOperator = Text -> OpName
OpName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity Text
tickedOperator forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity (Tokens Text)
normalOperator)
  where
    tickedOperator :: ParsecT Void Text Identity 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 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 Text
haskellIdentifier =
      Char -> Text -> Text
T.cons
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing (\Token Text
x -> Char -> Bool
Char.isAlphaNum 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
'\'')
    normalOperator :: ParsecT Void Text Identity (Tokens Text)
normalOperator =
      forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just FilePath
"operator character") forall a b. (a -> b) -> a -> b
$ \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
'`' 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
')')