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

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

    -- * Raw parsers
    pFixity,
    pOperator,
    pModuleName,
    pPackageName,

    -- * Internal
    isIdentifierFirstChar,
    isIdentifierConstituent,
    isOperatorConstituent,
    isPackageNameConstituent,
    isModuleSegmentFirstChar,
    isModuleSegmentConstituent,
  )
where

import Control.Monad (void, when)
import Data.Bifunctor (bimap)
import Data.Char (isAlphaNum, isUpper)
import Data.Char qualified as Char
import Data.Either (partitionEithers)
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as T
import Data.Void (Void)
import Distribution.ModuleName (ModuleName)
import Distribution.ModuleName qualified as ModuleName
import Distribution.Types.PackageName (PackageName, mkPackageName)
import Ormolu.Fixity
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L

type Parser = Parsec Void Text

-- | Parse textual representation of 'FixityOverrides'.
parseDotOrmolu ::
  -- | Location of the file we are parsing (only for parse errors)
  FilePath ->
  -- | File contents to parse
  Text ->
  -- | Parse result
  Either (ParseErrorBundle Text Void) (FixityOverrides, ModuleReexports)
parseDotOrmolu :: [Char]
-> Text
-> Either
     (ParseErrorBundle Text Void) (FixityOverrides, ModuleReexports)
parseDotOrmolu = forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
runParser Parser (FixityOverrides, ModuleReexports)
pDotOrmolu

-- | Parse a single self-contained fixity declaration.
parseFixityDeclaration ::
  -- | Text 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 -> [Char] -> 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) [Char]
""

-- | Parse a single self-contained module re-export declaration.
parseModuleReexportDeclaration ::
  -- | Text to parse
  Text ->
  -- | Parse result
  Either
    (ParseErrorBundle Text Void)
    (ModuleName, NonEmpty ModuleName)
parseModuleReexportDeclaration :: Text
-> Either
     (ParseErrorBundle Text Void) (ModuleName, NonEmpty ModuleName)
parseModuleReexportDeclaration = forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
runParser (ParsecT Void Text Identity (ModuleName, NonEmpty ModuleName)
pModuleReexport forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) [Char]
""

pDotOrmolu :: Parser (FixityOverrides, ModuleReexports)
pDotOrmolu :: Parser (FixityOverrides, ModuleReexports)
pDotOrmolu =
  forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
    (Map OpName FixityInfo -> FixityOverrides
FixityOverrides forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat)
    (Map ModuleName (NonEmpty ModuleName) -> ModuleReexports
ModuleReexports forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. Ord a => NonEmpty a -> NonEmpty a
NE.sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 b. [Either a b] -> ([a], [b])
partitionEithers
    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
  (Either [(OpName, FixityInfo)] (ModuleName, NonEmpty ModuleName))
configLine
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  where
    configLine :: ParsecT
  Void
  Text
  Identity
  (Either [(OpName, FixityInfo)] (ModuleName, NonEmpty ModuleName))
configLine = do
      Either [(OpName, FixityInfo)] (ModuleName, NonEmpty ModuleName)
x <- forall (m :: * -> *) a b.
Alternative m =>
m a -> m b -> m (Either a b)
eitherP ParsecT Void Text Identity [(OpName, FixityInfo)]
pFixity ParsecT Void Text Identity (ModuleName, NonEmpty ModuleName)
pModuleReexport
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
      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 (m :: * -> *) a. Monad m => a -> m a
return Either [(OpName, FixityInfo)] (ModuleName, NonEmpty ModuleName)
x

-- | Parse a single fixity declaration, such as
--
-- > infixr 4 +++, >>>
pFixity :: Parser [(OpName, FixityInfo)]
pFixity :: ParsecT Void Text Identity [(OpName, FixityInfo)]
pFixity = do
  FixityDirection
fiDirection <- 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
offsetAtPrecedence <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  Int
fiPrecedence <- forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
fiPrecedence forall a. Ord a => a -> a -> Bool
> Int
9) forall a b. (a -> b) -> a -> b
$
    forall e s (m :: * -> *) a.
MonadParsec e s m =>
(ParseError s e -> ParseError s e) -> m a -> m a
region
      (forall s e. Int -> ParseError s e -> ParseError s e
setErrorOffset Int
offsetAtPrecedence)
      (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"precedence should not be greater than 9")
  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
FixityDirection
fiPrecedence :: Int
fiDirection :: FixityDirection
fiPrecedence :: Int
fiDirection :: 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 [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing Char -> Bool
isIdentifierConstituent
    normalOperator :: ParsecT Void Text Identity (Tokens Text)
normalOperator =
      forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just [Char]
"operator character") Char -> Bool
isOperatorConstituent

pModuleReexport :: Parser (ModuleName, NonEmpty ModuleName)
pModuleReexport :: ParsecT Void Text Identity (ModuleName, NonEmpty ModuleName)
pModuleReexport = do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"module")
  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
  ModuleName
exportingModule <- Parser ModuleName
pModuleName
  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
  forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"exports")
  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
  ModuleName
exportedModule <- Parser ModuleName
pModuleName
  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 (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
exportingModule, forall a. a -> NonEmpty a
NE.singleton ModuleName
exportedModule)

pModuleName :: Parser ModuleName
pModuleName :: Parser ModuleName
pModuleName =
  forall a. IsString a => [Char] -> a
ModuleName.fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"."
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy1 ParsecT Void Text Identity [Token Text]
pModuleSegment (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'.')
    forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"module name"
  where
    pModuleSegment :: ParsecT Void Text Identity [Token Text]
pModuleSegment = do
      Token Text
x <- forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isModuleSegmentFirstChar forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"capital letter"
      [Token Text]
xs <-
        forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many
          ( forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isModuleSegmentConstituent
              forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"module segment continuation"
          )
      forall (m :: * -> *) a. Monad m => a -> m a
return (Token Text
x forall a. a -> [a] -> [a]
: [Token Text]
xs)

pPackageName :: Parser PackageName
pPackageName :: Parser PackageName
pPackageName =
  [Char] -> PackageName
mkPackageName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isPackageNameConstituent) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"package name"

-- Internal predicates (exposed for testing)

isIdentifierFirstChar :: Char -> Bool
isIdentifierFirstChar :: Char -> Bool
isIdentifierFirstChar = Char -> Bool
Char.isLetter

isIdentifierConstituent :: Char -> Bool
isIdentifierConstituent :: Char -> Bool
isIdentifierConstituent Char
x = Char -> Bool
Char.isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'\''

isOperatorConstituent :: Char -> Bool
isOperatorConstituent :: Char -> Bool
isOperatorConstituent Char
x =
  (Char -> Bool
Char.isSymbol Char
x Bool -> Bool -> Bool
|| Char -> Bool
Char.isPunctuation Char
x)
    Bool -> Bool -> Bool
&& (Char
x forall a. Eq a => a -> a -> Bool
/= Char
',' Bool -> Bool -> Bool
&& Char
x forall a. Eq a => a -> a -> Bool
/= Char
'`' Bool -> Bool -> Bool
&& Char
x forall a. Eq a => a -> a -> Bool
/= Char
'(' Bool -> Bool -> Bool
&& Char
x forall a. Eq a => a -> a -> Bool
/= Char
')')

isPackageNameConstituent :: Char -> Bool
isPackageNameConstituent :: Char -> Bool
isPackageNameConstituent Char
x = Char
x forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Char
x

isModuleSegmentFirstChar :: Char -> Bool
isModuleSegmentFirstChar :: Char -> Bool
isModuleSegmentFirstChar Char
x = Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
&& Char -> Bool
isUpper Char
x

isModuleSegmentConstituent :: Char -> Bool
isModuleSegmentConstituent :: Char -> Bool
isModuleSegmentConstituent Char
x =
  Char
x forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Char
x