-- |
-- This module implements the desugaring pass which reapplies binary operators based
-- on their fixity data and removes explicit parentheses.
--
-- The value parser ignores fixity data when parsing binary operator applications, so
-- it is necessary to reorder them here.
--
module Language.PureScript.Sugar.Operators
  ( desugarSignedLiterals
  , RebracketCaller(..)
  , rebracket
  , rebracketFiltered
  , checkFixityExports
  ) where

import Prelude

import Language.PureScript.AST
import Language.PureScript.Crash (internalError)
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage', parU, rethrow, rethrowWithPosition)
import Language.PureScript.Externs (ExternsFile(..), ExternsFixity(..), ExternsTypeFixity(..))
import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent')
import Language.PureScript.Sugar.Operators.Binders (matchBinderOperators)
import Language.PureScript.Sugar.Operators.Expr (matchExprOperators)
import Language.PureScript.Sugar.Operators.Types (matchTypeOperators)
import Language.PureScript.Traversals (defS, sndM)
import Language.PureScript.Types (Constraint(..), SourceType, Type(..), everywhereOnTypesTopDownM, overConstraintArgs)

import Control.Monad (unless, (<=<))
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class (MonadSupply)

import Data.Either (partitionEithers)
import Data.Foldable (for_, traverse_)
import Data.Function (on)
import Data.Functor (($>))
import Data.Functor.Identity (Identity(..), runIdentity)
import Data.List (groupBy, sortOn)
import Data.Maybe (mapMaybe, listToMaybe)
import Data.Map qualified as M
import Data.Ord (Down(..))

import Language.PureScript.Constants.Libs qualified as C

-- |
-- Removes unary negation operators and replaces them with calls to `negate`.
--
desugarSignedLiterals :: Module -> Module
desugarSignedLiterals :: Module -> Module
desugarSignedLiterals (Module SourceSpan
ss [Comment]
coms ModuleName
mn [Declaration]
ds Maybe [DeclarationRef]
exts) =
  SourceSpan
-> [Comment]
-> ModuleName
-> [Declaration]
-> Maybe [DeclarationRef]
-> Module
Module SourceSpan
ss [Comment]
coms ModuleName
mn (forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Declaration
f' [Declaration]
ds) Maybe [DeclarationRef]
exts
  where
  (Declaration -> Declaration
f', Expr -> Expr
_, Binder -> Binder
_) = (Declaration -> Declaration)
-> (Expr -> Expr)
-> (Binder -> Binder)
-> (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)
everywhereOnValues forall a. a -> a
id Expr -> Expr
go forall a. a -> a
id
  go :: Expr -> Expr
go (UnaryMinus SourceSpan
ss' Expr
val) = Expr -> Expr -> Expr
App (SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss' (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos (Text -> Ident
Ident forall a. (Eq a, IsString a) => a
C.S_negate))) Expr
val
  go Expr
other = Expr
other

-- |
-- An operator associated with its declaration position, fixity, and the name
-- of the function or data constructor it is an alias for.
--
type FixityRecord op alias = (Qualified op, SourceSpan, Fixity, Qualified alias)
type ValueFixityRecord = FixityRecord (OpName 'ValueOpName) (Either Ident (ProperName 'ConstructorName))
type TypeFixityRecord = FixityRecord (OpName 'TypeOpName) (ProperName 'TypeName)

-- |
-- Remove explicit parentheses and reorder binary operator applications.
--
-- This pass requires name desugaring and export elaboration to have run first.
--
rebracket
  :: forall m
   . MonadError MultipleErrors m
  => MonadSupply m
  => [ExternsFile]
  -> Module
  -> m Module
rebracket :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadSupply m) =>
[ExternsFile] -> Module -> m Module
rebracket =
  forall (m :: * -> *).
(MonadError MultipleErrors m, MonadSupply m) =>
RebracketCaller
-> (Declaration -> Bool) -> [ExternsFile] -> Module -> m Module
rebracketFiltered RebracketCaller
CalledByCompile (forall a b. a -> b -> a
const Bool
True)

-- |
-- A version of `rebracket` which allows you to choose which declarations
-- should be affected. This is used in docs generation, where we want to
-- desugar type operators in instance declarations to ensure that instances are
-- paired up with their types correctly, but we don't want to desugar type
-- operators in value declarations.
--
rebracketFiltered
  :: forall m
   . MonadError MultipleErrors m
  => MonadSupply m
  => RebracketCaller
  -> (Declaration -> Bool)
  -> [ExternsFile]
  -> Module
  -> m Module
rebracketFiltered :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadSupply m) =>
RebracketCaller
-> (Declaration -> Bool) -> [ExternsFile] -> Module -> m Module
rebracketFiltered !RebracketCaller
caller Declaration -> Bool
pred_ [ExternsFile]
externs Module
m = do
  let ([ValueFixityRecord]
valueFixities, [TypeFixityRecord]
typeFixities) =
        forall a b. [Either a b] -> ([a], [b])
partitionEithers
          forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ExternsFile -> [Either ValueFixityRecord TypeFixityRecord]
externsFixities [ExternsFile]
externs
          forall a. [a] -> [a] -> [a]
++ Module -> [Either ValueFixityRecord TypeFixityRecord]
collectFixities Module
m

  forall op alias.
Ord op =>
(op -> SimpleErrorMessage) -> [FixityRecord op alias] -> m ()
ensureNoDuplicates' OpName 'ValueOpName -> SimpleErrorMessage
MultipleValueOpFixities [ValueFixityRecord]
valueFixities
  forall op alias.
Ord op =>
(op -> SimpleErrorMessage) -> [FixityRecord op alias] -> m ()
ensureNoDuplicates' OpName 'TypeOpName -> SimpleErrorMessage
MultipleTypeOpFixities [TypeFixityRecord]
typeFixities

  let valueOpTable :: [[(Qualified (OpName 'ValueOpName), Associativity)]]
valueOpTable = forall op alias.
[FixityRecord op alias] -> [[(Qualified op, Associativity)]]
customOperatorTable' [ValueFixityRecord]
valueFixities
  let valueAliased :: Map
  (Qualified (OpName 'ValueOpName))
  (Qualified (Either Ident (ProperName 'ConstructorName)))
valueAliased = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall op alias.
FixityRecord op alias -> (Qualified op, Qualified alias)
makeLookupEntry [ValueFixityRecord]
valueFixities)
  let typeOpTable :: [[(Qualified (OpName 'TypeOpName), Associativity)]]
typeOpTable = forall op alias.
[FixityRecord op alias] -> [[(Qualified op, Associativity)]]
customOperatorTable' [TypeFixityRecord]
typeFixities
  let typeAliased :: Map
  (Qualified (OpName 'TypeOpName)) (Qualified (ProperName 'TypeName))
typeAliased = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall op alias.
FixityRecord op alias -> (Qualified op, Qualified alias)
makeLookupEntry [TypeFixityRecord]
typeFixities)

  forall (m :: * -> *).
(MonadError MultipleErrors m, MonadSupply m) =>
RebracketCaller
-> (Declaration -> Bool)
-> [[(Qualified (OpName 'ValueOpName), Associativity)]]
-> [[(Qualified (OpName 'TypeOpName), Associativity)]]
-> Module
-> m Module
rebracketModule RebracketCaller
caller Declaration -> Bool
pred_ [[(Qualified (OpName 'ValueOpName), Associativity)]]
valueOpTable [[(Qualified (OpName 'TypeOpName), Associativity)]]
typeOpTable Module
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    Map
  (Qualified (OpName 'ValueOpName))
  (Qualified (Either Ident (ProperName 'ConstructorName)))
-> Map
     (Qualified (OpName 'TypeOpName)) (Qualified (ProperName 'TypeName))
-> Module
-> m Module
renameAliasedOperators Map
  (Qualified (OpName 'ValueOpName))
  (Qualified (Either Ident (ProperName 'ConstructorName)))
valueAliased Map
  (Qualified (OpName 'TypeOpName)) (Qualified (ProperName 'TypeName))
typeAliased

  where

  ensureNoDuplicates'
    :: Ord op
    => (op -> SimpleErrorMessage)
    -> [FixityRecord op alias]
    -> m ()
  ensureNoDuplicates' :: forall op alias.
Ord op =>
(op -> SimpleErrorMessage) -> [FixityRecord op alias] -> m ()
ensureNoDuplicates' op -> SimpleErrorMessage
toError =
    forall a (m :: * -> *).
(Ord a, MonadError MultipleErrors m) =>
(a -> SimpleErrorMessage) -> [(Qualified a, SourceSpan)] -> m ()
ensureNoDuplicates op -> SimpleErrorMessage
toError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(Qualified op
i, SourceSpan
pos, Fixity
_, Qualified alias
_) -> (Qualified op
i, SourceSpan
pos))

  customOperatorTable'
    :: [FixityRecord op alias]
    -> [[(Qualified op, Associativity)]]
  customOperatorTable' :: forall op alias.
[FixityRecord op alias] -> [[(Qualified op, Associativity)]]
customOperatorTable' = forall op.
[(Qualified op, Fixity)] -> [[(Qualified op, Associativity)]]
customOperatorTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(Qualified op
i, SourceSpan
_, Fixity
f, Qualified alias
_) -> (Qualified op
i, Fixity
f))

  makeLookupEntry :: FixityRecord op alias -> (Qualified op, Qualified alias)
  makeLookupEntry :: forall op alias.
FixityRecord op alias -> (Qualified op, Qualified alias)
makeLookupEntry (Qualified op
qname, SourceSpan
_, Fixity
_, Qualified alias
alias) = (Qualified op
qname, Qualified alias
alias)

  renameAliasedOperators
    :: M.Map (Qualified (OpName 'ValueOpName)) (Qualified (Either Ident (ProperName 'ConstructorName)))
    -> M.Map (Qualified (OpName 'TypeOpName)) (Qualified (ProperName 'TypeName))
    -> Module
    -> m Module
  renameAliasedOperators :: Map
  (Qualified (OpName 'ValueOpName))
  (Qualified (Either Ident (ProperName 'ConstructorName)))
-> Map
     (Qualified (OpName 'TypeOpName)) (Qualified (ProperName 'TypeName))
-> Module
-> m Module
renameAliasedOperators Map
  (Qualified (OpName 'ValueOpName))
  (Qualified (Either Ident (ProperName 'ConstructorName)))
valueAliased Map
  (Qualified (OpName 'TypeOpName)) (Qualified (ProperName 'TypeName))
typeAliased (Module SourceSpan
ss [Comment]
coms ModuleName
mn [Declaration]
ds Maybe [DeclarationRef]
exts) =
    SourceSpan
-> [Comment]
-> ModuleName
-> [Declaration]
-> Maybe [DeclarationRef]
-> Module
Module SourceSpan
ss [Comment]
coms ModuleName
mn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a.
Applicative f =>
(a -> Bool) -> (a -> f a) -> a -> f a
usingPredicate Declaration -> Bool
pred_ Declaration -> m Declaration
f') [Declaration]
ds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DeclarationRef]
exts
    where
    (Declaration -> m Declaration
goDecl', SourceSpan -> Expr -> m (SourceSpan, Expr)
goExpr', SourceSpan -> Binder -> m (SourceSpan, Binder)
goBinder') = forall (m :: * -> *).
Monad m =>
(SourceSpan -> SourceType -> m SourceType)
-> (Declaration -> m Declaration,
    SourceSpan -> Expr -> m (SourceSpan, Expr),
    SourceSpan -> Binder -> m (SourceSpan, Binder))
updateTypes SourceSpan -> SourceType -> m SourceType
goType
    (Declaration -> m Declaration
f', Expr -> m Expr
_, Binder -> m Binder
_, CaseAlternative -> m CaseAlternative
_, DoNotationElement -> m DoNotationElement
_, Guard -> m Guard
_) =
      forall (m :: * -> *) s.
Monad m =>
s
-> (s -> Declaration -> m (s, Declaration))
-> (s -> Expr -> m (s, Expr))
-> (s -> Binder -> m (s, Binder))
-> (s -> CaseAlternative -> m (s, CaseAlternative))
-> (s -> DoNotationElement -> m (s, DoNotationElement))
-> (s -> Guard -> m (s, Guard))
-> (Declaration -> m Declaration, Expr -> m Expr,
    Binder -> m Binder, CaseAlternative -> m CaseAlternative,
    DoNotationElement -> m DoNotationElement, Guard -> m Guard)
everywhereWithContextOnValuesM
        SourceSpan
ss
        (\SourceSpan
_ Declaration
d -> (Declaration -> SourceSpan
declSourceSpan Declaration
d,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Declaration -> m Declaration
goDecl' Declaration
d)
        (\SourceSpan
pos -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SourceSpan -> Expr -> m (SourceSpan, Expr)
goExpr forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< SourceSpan -> Expr -> m (SourceSpan, Expr)
goExpr' SourceSpan
pos)
        (\SourceSpan
pos -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SourceSpan -> Binder -> m (SourceSpan, Binder)
goBinder forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< SourceSpan -> Binder -> m (SourceSpan, Binder)
goBinder' SourceSpan
pos)
        forall (m :: * -> *) st val. Monad m => st -> val -> m (st, val)
defS
        forall (m :: * -> *) st val. Monad m => st -> val -> m (st, val)
defS
        forall (m :: * -> *) st val. Monad m => st -> val -> m (st, val)
defS

    goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr)
    goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr)
goExpr SourceSpan
_ e :: Expr
e@(PositionedValue SourceSpan
pos [Comment]
_ Expr
_) = forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
pos, Expr
e)
    goExpr SourceSpan
_ (Op SourceSpan
pos Qualified (OpName 'ValueOpName)
op) =
      (SourceSpan
pos,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Qualified (OpName 'ValueOpName)
op forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map
  (Qualified (OpName 'ValueOpName))
  (Qualified (Either Ident (ProperName 'ConstructorName)))
valueAliased of
        Just (Qualified QualifiedBy
mn' (Left Ident
alias)) ->
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
pos (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
mn' Ident
alias)
        Just (Qualified QualifiedBy
mn' (Right ProperName 'ConstructorName
alias)) ->
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceSpan -> Qualified (ProperName 'ConstructorName) -> Expr
Constructor SourceSpan
pos (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
mn' ProperName 'ConstructorName
alias)
        Maybe (Qualified (Either Ident (ProperName 'ConstructorName)))
Nothing ->
          forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualified Name -> SimpleErrorMessage
UnknownName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OpName 'ValueOpName -> Name
ValOpName Qualified (OpName 'ValueOpName)
op
    goExpr SourceSpan
pos Expr
other = forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
pos, Expr
other)

    goBinder :: SourceSpan -> Binder -> m (SourceSpan, Binder)
    goBinder :: SourceSpan -> Binder -> m (SourceSpan, Binder)
goBinder SourceSpan
_ b :: Binder
b@(PositionedBinder SourceSpan
pos [Comment]
_ Binder
_) = forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
pos, Binder
b)
    goBinder SourceSpan
_ (BinaryNoParensBinder (OpBinder SourceSpan
pos Qualified (OpName 'ValueOpName)
op) Binder
lhs Binder
rhs) =
      case Qualified (OpName 'ValueOpName)
op forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map
  (Qualified (OpName 'ValueOpName))
  (Qualified (Either Ident (ProperName 'ConstructorName)))
valueAliased of
        Just (Qualified QualifiedBy
mn' (Left Ident
alias)) ->
          forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
pos forall a b. (a -> b) -> a -> b
$ Qualified (OpName 'ValueOpName)
-> Qualified Ident -> SimpleErrorMessage
InvalidOperatorInBinder Qualified (OpName 'ValueOpName)
op (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
mn' Ident
alias)
        Just (Qualified QualifiedBy
mn' (Right ProperName 'ConstructorName
alias)) ->
          forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
pos, SourceSpan
-> Qualified (ProperName 'ConstructorName) -> [Binder] -> Binder
ConstructorBinder SourceSpan
pos (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
mn' ProperName 'ConstructorName
alias) [Binder
lhs, Binder
rhs])
        Maybe (Qualified (Either Ident (ProperName 'ConstructorName)))
Nothing ->
          forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualified Name -> SimpleErrorMessage
UnknownName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OpName 'ValueOpName -> Name
ValOpName Qualified (OpName 'ValueOpName)
op
    goBinder SourceSpan
_ BinaryNoParensBinder{} =
      forall a. HasCallStack => String -> a
internalError String
"BinaryNoParensBinder has no OpBinder"
    goBinder SourceSpan
pos Binder
other = forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
pos, Binder
other)

    goType :: SourceSpan -> SourceType -> m SourceType
    goType :: SourceSpan -> SourceType -> m SourceType
goType SourceSpan
pos (TypeOp SourceAnn
ann2 Qualified (OpName 'TypeOpName)
op) =
      case Qualified (OpName 'TypeOpName)
op forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map
  (Qualified (OpName 'TypeOpName)) (Qualified (ProperName 'TypeName))
typeAliased of
        Just Qualified (ProperName 'TypeName)
alias ->
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified (ProperName 'TypeName) -> Type a
TypeConstructor SourceAnn
ann2 Qualified (ProperName 'TypeName)
alias
        Maybe (Qualified (ProperName 'TypeName))
Nothing ->
          forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
pos forall a b. (a -> b) -> a -> b
$ Qualified Name -> SimpleErrorMessage
UnknownName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OpName 'TypeOpName -> Name
TyOpName Qualified (OpName 'TypeOpName)
op
    goType SourceSpan
_ SourceType
other = forall (m :: * -> *) a. Monad m => a -> m a
return SourceType
other

-- | Indicates whether the `rebracketModule`
-- is being called with the full desugar pass
-- run via `purs compile` or whether
-- only the partial desugar pass is run
-- via `purs docs`.
-- This indication is needed to prevent
-- a `purs docs` error when using
-- `case _ of` syntax in a type class instance.
data RebracketCaller
  = CalledByCompile
  | CalledByDocs
  deriving (RebracketCaller -> RebracketCaller -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RebracketCaller -> RebracketCaller -> Bool
$c/= :: RebracketCaller -> RebracketCaller -> Bool
== :: RebracketCaller -> RebracketCaller -> Bool
$c== :: RebracketCaller -> RebracketCaller -> Bool
Eq, Int -> RebracketCaller -> ShowS
[RebracketCaller] -> ShowS
RebracketCaller -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RebracketCaller] -> ShowS
$cshowList :: [RebracketCaller] -> ShowS
show :: RebracketCaller -> String
$cshow :: RebracketCaller -> String
showsPrec :: Int -> RebracketCaller -> ShowS
$cshowsPrec :: Int -> RebracketCaller -> ShowS
Show)

rebracketModule
  :: forall m
   . (MonadError MultipleErrors m)
  => MonadSupply m
  => RebracketCaller
  -> (Declaration -> Bool)
  -> [[(Qualified (OpName 'ValueOpName), Associativity)]]
  -> [[(Qualified (OpName 'TypeOpName), Associativity)]]
  -> Module
  -> m Module
rebracketModule :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadSupply m) =>
RebracketCaller
-> (Declaration -> Bool)
-> [[(Qualified (OpName 'ValueOpName), Associativity)]]
-> [[(Qualified (OpName 'TypeOpName), Associativity)]]
-> Module
-> m Module
rebracketModule !RebracketCaller
caller Declaration -> Bool
pred_ [[(Qualified (OpName 'ValueOpName), Associativity)]]
valueOpTable [[(Qualified (OpName 'TypeOpName), Associativity)]]
typeOpTable (Module SourceSpan
ss [Comment]
coms ModuleName
mn [Declaration]
ds Maybe [DeclarationRef]
exts) =
  SourceSpan
-> [Comment]
-> ModuleName
-> [Declaration]
-> Maybe [DeclarationRef]
-> Module
Module SourceSpan
ss [Comment]
coms ModuleName
mn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration] -> m [Declaration]
f' [Declaration]
ds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DeclarationRef]
exts
  where
  f' :: [Declaration] -> m [Declaration]
  f' :: [Declaration] -> m [Declaration]
f' =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (\Declaration
d -> if Declaration -> Bool
pred_ Declaration
d then Declaration -> Declaration
removeParens Declaration
d else Declaration
d)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU (forall (f :: * -> *) a.
Applicative f =>
(a -> Bool) -> (a -> f a) -> a -> f a
usingPredicate Declaration -> Bool
pred_ Declaration -> m Declaration
h)

  -- The AST will run through all the desugar passes when compiling
  -- and only some of the desugar passes when generating docs.
  -- When generating docs, `case _ of` syntax used in an instance declaration
  -- can trigger the `IncorrectAnonymousArgument` error because it does not
  -- run the same passes that the compile desugaring does. Since `purs docs`
  -- will only succeed once `purs compile` succeeds, we can ignore this check
  -- when running `purs docs`.
  -- See https://github.com/purescript/purescript/issues/4274#issuecomment-1087730651=
  -- for more info.
  h :: Declaration -> m Declaration
  h :: Declaration -> m Declaration
h = case RebracketCaller
caller of
    RebracketCaller
CalledByDocs -> Declaration -> m Declaration
f
    RebracketCaller
CalledByCompile -> Declaration -> m Declaration
g forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Declaration -> m Declaration
f

  (Declaration -> m Declaration
f, Expr -> m Expr
_, Binder -> m Binder
_, CaseAlternative -> m CaseAlternative
_, DoNotationElement -> m DoNotationElement
_, Guard -> m Guard
_) =
      forall (m :: * -> *) s.
Monad m =>
s
-> (s -> Declaration -> m (s, Declaration))
-> (s -> Expr -> m (s, Expr))
-> (s -> Binder -> m (s, Binder))
-> (s -> CaseAlternative -> m (s, CaseAlternative))
-> (s -> DoNotationElement -> m (s, DoNotationElement))
-> (s -> Guard -> m (s, Guard))
-> (Declaration -> m Declaration, Expr -> m Expr,
    Binder -> m Binder, CaseAlternative -> m CaseAlternative,
    DoNotationElement -> m DoNotationElement, Guard -> m Guard)
everywhereWithContextOnValuesM
        SourceSpan
ss
        (\SourceSpan
_ Declaration
d -> (Declaration -> SourceSpan
declSourceSpan Declaration
d,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Declaration -> m Declaration
goDecl Declaration
d)
        (\SourceSpan
pos -> forall a. (a -> m a) -> (SourceSpan, a) -> m (SourceSpan, a)
wrap (forall (m :: * -> *).
MonadError MultipleErrors m =>
[[(Qualified (OpName 'ValueOpName), Associativity)]]
-> Expr -> m Expr
matchExprOperators [[(Qualified (OpName 'ValueOpName), Associativity)]]
valueOpTable) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< SourceSpan -> Expr -> m (SourceSpan, Expr)
goExpr' SourceSpan
pos)
        (\SourceSpan
pos -> forall a. (a -> m a) -> (SourceSpan, a) -> m (SourceSpan, a)
wrap (forall (m :: * -> *).
MonadError MultipleErrors m =>
[[(Qualified (OpName 'ValueOpName), Associativity)]]
-> Binder -> m Binder
matchBinderOperators [[(Qualified (OpName 'ValueOpName), Associativity)]]
valueOpTable) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< SourceSpan -> Binder -> m (SourceSpan, Binder)
goBinder' SourceSpan
pos)
        forall (m :: * -> *) st val. Monad m => st -> val -> m (st, val)
defS
        forall (m :: * -> *) st val. Monad m => st -> val -> m (st, val)
defS
        forall (m :: * -> *) st val. Monad m => st -> val -> m (st, val)
defS

  (Declaration -> m Declaration
g, Expr -> m Expr
_, Binder -> m Binder
_) = forall (m :: * -> *).
Monad m =>
(Declaration -> m Declaration)
-> (Expr -> m Expr)
-> (Binder -> m Binder)
-> (Declaration -> m Declaration, Expr -> m Expr,
    Binder -> m Binder)
everywhereOnValuesTopDownM forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *).
(MonadError MultipleErrors m, MonadSupply m) =>
Expr -> m Expr
removeBinaryNoParens forall (f :: * -> *) a. Applicative f => a -> f a
pure

  (Declaration -> m Declaration
goDecl, SourceSpan -> Expr -> m (SourceSpan, Expr)
goExpr', SourceSpan -> Binder -> m (SourceSpan, Binder)
goBinder') = forall (m :: * -> *).
Monad m =>
(SourceSpan -> SourceType -> m SourceType)
-> (Declaration -> m Declaration,
    SourceSpan -> Expr -> m (SourceSpan, Expr),
    SourceSpan -> Binder -> m (SourceSpan, Binder))
updateTypes SourceSpan -> SourceType -> m SourceType
goType

  goType :: SourceSpan -> SourceType -> m SourceType
  goType :: SourceSpan -> SourceType -> m SourceType
goType = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> [[(Qualified (OpName 'TypeOpName), Associativity)]]
-> SourceType
-> m SourceType
matchTypeOperators [[(Qualified (OpName 'TypeOpName), Associativity)]]
typeOpTable

  wrap :: (a -> m a) -> (SourceSpan, a) -> m (SourceSpan, a)
  wrap :: forall a. (a -> m a) -> (SourceSpan, a) -> m (SourceSpan, a)
wrap a -> m a
go (SourceSpan
ss', a
a) = (SourceSpan
ss',) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m a
go a
a

removeBinaryNoParens :: (MonadError MultipleErrors m, MonadSupply m) => Expr -> m Expr
removeBinaryNoParens :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadSupply m) =>
Expr -> m Expr
removeBinaryNoParens Expr
u
  | Expr -> Bool
isAnonymousArgument Expr
u = case Expr
u of
                              PositionedValue SourceSpan
p [Comment]
_ Expr
_ -> forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> m a -> m a
rethrowWithPosition SourceSpan
p forall {a}. m a
err
                              Expr
_ -> forall {a}. m a
err
                            where err :: m a
err = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ SimpleErrorMessage
IncorrectAnonymousArgument
removeBinaryNoParens (Parens (Expr -> Expr
stripPositionInfo -> BinaryNoParens Expr
op Expr
l Expr
r))
  | Expr -> Bool
isAnonymousArgument Expr
r = do Ident
arg <- forall (m :: * -> *). MonadSupply m => m Ident
freshIdent'
                               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
nullSourceSpan Ident
arg) forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App Expr
op Expr
l) (SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
nullSourceSpan (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Ident
arg))
  | Expr -> Bool
isAnonymousArgument Expr
l = do Ident
arg <- forall (m :: * -> *). MonadSupply m => m Ident
freshIdent'
                               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
nullSourceSpan Ident
arg) forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App Expr
op (SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
nullSourceSpan (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Ident
arg))) Expr
r
removeBinaryNoParens (BinaryNoParens Expr
op Expr
l Expr
r) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App Expr
op Expr
l) Expr
r
removeBinaryNoParens Expr
e = forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e

stripPositionInfo :: Expr -> Expr
stripPositionInfo :: Expr -> Expr
stripPositionInfo (PositionedValue SourceSpan
_ [Comment]
_ Expr
e) = Expr -> Expr
stripPositionInfo Expr
e
stripPositionInfo Expr
e = Expr
e

removeParens :: Declaration -> Declaration
removeParens :: Declaration -> Declaration
removeParens = Declaration -> Declaration
f
  where
  (Declaration -> Declaration
f, Expr -> Expr
_, Binder -> Binder
_) =
      (Declaration -> Declaration)
-> (Expr -> Expr)
-> (Binder -> Binder)
-> (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)
everywhereOnValues
        (forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> Identity Declaration
goDecl)
        (Expr -> Expr
goExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (SourceSpan -> a -> Identity (SourceSpan, a)) -> a -> a
decontextify SourceSpan -> Expr -> Identity (SourceSpan, Expr)
goExpr')
        (Binder -> Binder
goBinder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (SourceSpan -> a -> Identity (SourceSpan, a)) -> a -> a
decontextify SourceSpan -> Binder -> Identity (SourceSpan, Binder)
goBinder')

  (Declaration -> Identity Declaration
goDecl, SourceSpan -> Expr -> Identity (SourceSpan, Expr)
goExpr', SourceSpan -> Binder -> Identity (SourceSpan, Binder)
goBinder') = forall (m :: * -> *).
Monad m =>
(SourceSpan -> SourceType -> m SourceType)
-> (Declaration -> m Declaration,
    SourceSpan -> Expr -> m (SourceSpan, Expr),
    SourceSpan -> Binder -> m (SourceSpan, Binder))
updateTypes (\SourceSpan
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type a -> Type a
goType)

  goExpr :: Expr -> Expr
  goExpr :: Expr -> Expr
goExpr (Parens Expr
val) = Expr -> Expr
goExpr Expr
val
  goExpr Expr
val = Expr
val

  goBinder :: Binder -> Binder
  goBinder :: Binder -> Binder
goBinder (ParensInBinder Binder
b) = Binder -> Binder
goBinder Binder
b
  goBinder Binder
b = Binder
b

  goType :: Type a -> Type a
  goType :: forall a. Type a -> Type a
goType (ParensInType a
_ Type a
t) = forall a. Type a -> Type a
goType Type a
t
  goType Type a
t = Type a
t

  decontextify
    :: (SourceSpan -> a -> Identity (SourceSpan, a))
    -> a
    -> a
  decontextify :: forall a. (SourceSpan -> a -> Identity (SourceSpan, a)) -> a -> a
decontextify SourceSpan -> a -> Identity (SourceSpan, a)
ctxf = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> a -> Identity (SourceSpan, a)
ctxf (forall a. HasCallStack => String -> a
internalError String
"attempted to use SourceSpan in removeParens")

externsFixities :: ExternsFile -> [Either ValueFixityRecord TypeFixityRecord]
externsFixities :: ExternsFile -> [Either ValueFixityRecord TypeFixityRecord]
externsFixities ExternsFile{[DeclarationRef]
[ExternsDeclaration]
[ExternsTypeFixity]
[ExternsFixity]
[ExternsImport]
Text
SourceSpan
ModuleName
efSourceSpan :: ExternsFile -> SourceSpan
efDeclarations :: ExternsFile -> [ExternsDeclaration]
efTypeFixities :: ExternsFile -> [ExternsTypeFixity]
efFixities :: ExternsFile -> [ExternsFixity]
efImports :: ExternsFile -> [ExternsImport]
efExports :: ExternsFile -> [DeclarationRef]
efModuleName :: ExternsFile -> ModuleName
efVersion :: ExternsFile -> Text
efSourceSpan :: SourceSpan
efDeclarations :: [ExternsDeclaration]
efTypeFixities :: [ExternsTypeFixity]
efFixities :: [ExternsFixity]
efImports :: [ExternsImport]
efExports :: [DeclarationRef]
efModuleName :: ModuleName
efVersion :: Text
..} =
  forall a b. (a -> b) -> [a] -> [b]
map ExternsFixity -> Either ValueFixityRecord TypeFixityRecord
fromFixity [ExternsFixity]
efFixities forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map ExternsTypeFixity -> Either ValueFixityRecord TypeFixityRecord
fromTypeFixity [ExternsTypeFixity]
efTypeFixities
  where

  fromFixity
    :: ExternsFixity
    -> Either ValueFixityRecord TypeFixityRecord
  fromFixity :: ExternsFixity -> Either ValueFixityRecord TypeFixityRecord
fromFixity (ExternsFixity Associativity
assoc Precedence
prec OpName 'ValueOpName
op Qualified (Either Ident (ProperName 'ConstructorName))
name) =
    forall a b. a -> Either a b
Left
      ( forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
efModuleName) OpName 'ValueOpName
op
      , String -> SourceSpan
internalModuleSourceSpan String
""
      , Associativity -> Precedence -> Fixity
Fixity Associativity
assoc Precedence
prec
      , Qualified (Either Ident (ProperName 'ConstructorName))
name
      )

  fromTypeFixity
    :: ExternsTypeFixity
    -> Either ValueFixityRecord TypeFixityRecord
  fromTypeFixity :: ExternsTypeFixity -> Either ValueFixityRecord TypeFixityRecord
fromTypeFixity (ExternsTypeFixity Associativity
assoc Precedence
prec OpName 'TypeOpName
op Qualified (ProperName 'TypeName)
name) =
    forall a b. b -> Either a b
Right
      ( forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
efModuleName) OpName 'TypeOpName
op
      , String -> SourceSpan
internalModuleSourceSpan String
""
      , Associativity -> Precedence -> Fixity
Fixity Associativity
assoc Precedence
prec
      , Qualified (ProperName 'TypeName)
name
      )

collectFixities :: Module -> [Either ValueFixityRecord TypeFixityRecord]
collectFixities :: Module -> [Either ValueFixityRecord TypeFixityRecord]
collectFixities (Module SourceSpan
_ [Comment]
_ ModuleName
moduleName [Declaration]
ds Maybe [DeclarationRef]
_) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [Either ValueFixityRecord TypeFixityRecord]
collect [Declaration]
ds
  where
  collect :: Declaration -> [Either ValueFixityRecord TypeFixityRecord]
  collect :: Declaration -> [Either ValueFixityRecord TypeFixityRecord]
collect (ValueFixityDeclaration (SourceSpan
ss, [Comment]
_) Fixity
fixity Qualified (Either Ident (ProperName 'ConstructorName))
name OpName 'ValueOpName
op) =
    [forall a b. a -> Either a b
Left (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) OpName 'ValueOpName
op, SourceSpan
ss, Fixity
fixity, Qualified (Either Ident (ProperName 'ConstructorName))
name)]
  collect (TypeFixityDeclaration (SourceSpan
ss, [Comment]
_) Fixity
fixity Qualified (ProperName 'TypeName)
name OpName 'TypeOpName
op) =
    [forall a b. b -> Either a b
Right (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) OpName 'TypeOpName
op, SourceSpan
ss, Fixity
fixity, Qualified (ProperName 'TypeName)
name)]
  collect Declaration
_ = []

ensureNoDuplicates
  :: (Ord a, MonadError MultipleErrors m)
  => (a -> SimpleErrorMessage)
  -> [(Qualified a, SourceSpan)]
  -> m ()
ensureNoDuplicates :: forall a (m :: * -> *).
(Ord a, MonadError MultipleErrors m) =>
(a -> SimpleErrorMessage) -> [(Qualified a, SourceSpan)] -> m ()
ensureNoDuplicates a -> SimpleErrorMessage
toError [(Qualified a, SourceSpan)]
m = [(Qualified a, SourceSpan)] -> m ()
go forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst [(Qualified a, SourceSpan)]
m
  where
  go :: [(Qualified a, SourceSpan)] -> m ()
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  go [(Qualified a, SourceSpan)
_] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  go ((x :: Qualified a
x@(Qualified (ByModuleName ModuleName
mn) a
op), SourceSpan
_) : (Qualified a
y, SourceSpan
pos) : [(Qualified a, SourceSpan)]
_) | Qualified a
x forall a. Eq a => a -> a -> Bool
== Qualified a
y =
    forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
rethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ModuleName -> ErrorMessageHint
ErrorInModule ModuleName
mn)) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> m a -> m a
rethrowWithPosition SourceSpan
pos forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ a -> SimpleErrorMessage
toError a
op
  go ((Qualified a, SourceSpan)
_ : [(Qualified a, SourceSpan)]
rest) = [(Qualified a, SourceSpan)] -> m ()
go [(Qualified a, SourceSpan)]
rest

customOperatorTable
  :: [(Qualified op, Fixity)]
  -> [[(Qualified op, Associativity)]]
customOperatorTable :: forall op.
[(Qualified op, Fixity)] -> [[(Qualified op, Associativity)]]
customOperatorTable [(Qualified op, Fixity)]
fixities =
  let
    userOps :: [(Qualified op, Precedence, Associativity)]
userOps = forall a b. (a -> b) -> [a] -> [b]
map (\(Qualified op
name, Fixity Associativity
a Precedence
p) -> (Qualified op
name, Precedence
p, Associativity
a)) [(Qualified op, Fixity)]
fixities
    sorted :: [(Qualified op, Precedence, Associativity)]
sorted = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Qualified op
_, Precedence
p, Associativity
_) -> Precedence
p)) [(Qualified op, Precedence, Associativity)]
userOps
    groups :: [[(Qualified op, Precedence, Associativity)]]
groups = forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(Qualified op
_, Precedence
p, Associativity
_) -> Precedence
p)) [(Qualified op, Precedence, Associativity)]
sorted
  in
    forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (\(Qualified op
name, Precedence
_, Associativity
a) -> (Qualified op
name, Associativity
a))) [[(Qualified op, Precedence, Associativity)]]
groups

updateTypes
  :: forall m
   . Monad m
  => (SourceSpan -> SourceType -> m SourceType)
  -> ( Declaration -> m Declaration
     , SourceSpan -> Expr -> m (SourceSpan, Expr)
     , SourceSpan -> Binder -> m (SourceSpan, Binder)
     )
updateTypes :: forall (m :: * -> *).
Monad m =>
(SourceSpan -> SourceType -> m SourceType)
-> (Declaration -> m Declaration,
    SourceSpan -> Expr -> m (SourceSpan, Expr),
    SourceSpan -> Binder -> m (SourceSpan, Binder))
updateTypes SourceSpan -> SourceType -> m SourceType
goType = (Declaration -> m Declaration
goDecl, SourceSpan -> Expr -> m (SourceSpan, Expr)
goExpr, SourceSpan -> Binder -> m (SourceSpan, Binder)
goBinder)
  where

  goType' :: SourceSpan -> SourceType -> m SourceType
  goType' :: SourceSpan -> SourceType -> m SourceType
goType' = forall (m :: * -> *) a.
Monad m =>
(Type a -> m (Type a)) -> Type a -> m (Type a)
everywhereOnTypesTopDownM forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SourceType -> m SourceType
goType

  goDecl :: Declaration -> m Declaration
  goDecl :: Declaration -> m Declaration
goDecl (DataDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) DataDeclType
ddt ProperName 'TypeName
name [(Text, Maybe SourceType)]
args [DataConstructorDeclaration]
dctors) =
    SourceAnn
-> DataDeclType
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> [DataConstructorDeclaration]
-> Declaration
DataDeclaration SourceAnn
sa DataDeclType
ddt ProperName 'TypeName
name
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
ss))) [(Text, Maybe SourceType)]
args
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
Monad m =>
([(Ident, SourceType)] -> m [(Ident, SourceType)])
-> DataConstructorDeclaration -> m DataConstructorDeclaration
traverseDataCtorFields (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) b c a.
Functor f =>
(b -> f c) -> (a, b) -> f (a, c)
sndM (SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
ss)))) [DataConstructorDeclaration]
dctors
  goDecl (ExternDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) Ident
name SourceType
ty) =
    SourceAnn -> Ident -> SourceType -> Declaration
ExternDeclaration SourceAnn
sa Ident
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
ss SourceType
ty
  goDecl (TypeClassDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) ProperName 'ClassName
name [(Text, Maybe SourceType)]
args [SourceConstraint]
implies [FunctionalDependency]
deps [Declaration]
decls) = do
    [SourceConstraint]
implies' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) a.
Functor f =>
([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a)
overConstraintArgs (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
ss))) [SourceConstraint]
implies
    [(Text, Maybe SourceType)]
args' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
ss))) [(Text, Maybe SourceType)]
args
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceAnn
-> ProperName 'ClassName
-> [(Text, Maybe SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> [Declaration]
-> Declaration
TypeClassDeclaration SourceAnn
sa ProperName 'ClassName
name [(Text, Maybe SourceType)]
args' [SourceConstraint]
implies' [FunctionalDependency]
deps [Declaration]
decls
  goDecl (TypeInstanceDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) SourceAnn
na ChainId
ch Precedence
idx Either Text Ident
name [SourceConstraint]
cs Qualified (ProperName 'ClassName)
className [SourceType]
tys TypeInstanceBody
impls) = do
    [SourceConstraint]
cs' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) a.
Functor f =>
([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a)
overConstraintArgs (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
ss))) [SourceConstraint]
cs
    [SourceType]
tys' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
ss) [SourceType]
tys
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceAnn
-> SourceAnn
-> ChainId
-> Precedence
-> Either Text Ident
-> [SourceConstraint]
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> TypeInstanceBody
-> Declaration
TypeInstanceDeclaration SourceAnn
sa SourceAnn
na ChainId
ch Precedence
idx Either Text Ident
name [SourceConstraint]
cs' Qualified (ProperName 'ClassName)
className [SourceType]
tys' TypeInstanceBody
impls
  goDecl (TypeSynonymDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) ProperName 'TypeName
name [(Text, Maybe SourceType)]
args SourceType
ty) =
    SourceAnn
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> SourceType
-> Declaration
TypeSynonymDeclaration SourceAnn
sa ProperName 'TypeName
name
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
ss))) [(Text, Maybe SourceType)]
args
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
ss SourceType
ty
  goDecl (TypeDeclaration (TypeDeclarationData sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) Ident
expr SourceType
ty)) =
    TypeDeclarationData -> Declaration
TypeDeclaration forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceAnn -> Ident -> SourceType -> TypeDeclarationData
TypeDeclarationData SourceAnn
sa Ident
expr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
ss SourceType
ty
  goDecl (KindDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) KindSignatureFor
sigFor ProperName 'TypeName
name SourceType
ty) =
    SourceAnn
-> KindSignatureFor
-> ProperName 'TypeName
-> SourceType
-> Declaration
KindDeclaration SourceAnn
sa KindSignatureFor
sigFor ProperName 'TypeName
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
ss SourceType
ty
  goDecl (ExternDataDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) ProperName 'TypeName
name SourceType
ty) =
    SourceAnn -> ProperName 'TypeName -> SourceType -> Declaration
ExternDataDeclaration SourceAnn
sa ProperName 'TypeName
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
ss SourceType
ty
  goDecl Declaration
other =
    forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
other

  goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr)
  goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr)
goExpr SourceSpan
_ e :: Expr
e@(PositionedValue SourceSpan
pos [Comment]
_ Expr
_) = forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
pos, Expr
e)
  goExpr SourceSpan
pos (TypeClassDictionary (Constraint SourceAnn
ann Qualified (ProperName 'ClassName)
name [SourceType]
kinds [SourceType]
tys Maybe ConstraintData
info) Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
dicts [ErrorMessageHint]
hints) = do
    [SourceType]
kinds' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
pos) [SourceType]
kinds
    [SourceType]
tys' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
pos) [SourceType]
tys
    forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
pos, SourceConstraint
-> Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
-> [ErrorMessageHint]
-> Expr
TypeClassDictionary (forall a.
a
-> Qualified (ProperName 'ClassName)
-> [Type a]
-> [Type a]
-> Maybe ConstraintData
-> Constraint a
Constraint SourceAnn
ann Qualified (ProperName 'ClassName)
name [SourceType]
kinds' [SourceType]
tys' Maybe ConstraintData
info) Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
dicts [ErrorMessageHint]
hints)
  goExpr SourceSpan
pos (DeferredDictionary Qualified (ProperName 'ClassName)
cls [SourceType]
tys) = do
    [SourceType]
tys' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
pos) [SourceType]
tys
    forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
pos, Qualified (ProperName 'ClassName) -> [SourceType] -> Expr
DeferredDictionary Qualified (ProperName 'ClassName)
cls [SourceType]
tys')
  goExpr SourceSpan
pos (TypedValue Bool
check Expr
v SourceType
ty) = do
    SourceType
ty' <- SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
pos SourceType
ty
    forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
pos, Bool -> Expr -> SourceType -> Expr
TypedValue Bool
check Expr
v SourceType
ty')
  goExpr SourceSpan
pos Expr
other = forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
pos, Expr
other)

  goBinder :: SourceSpan -> Binder -> m (SourceSpan, Binder)
  goBinder :: SourceSpan -> Binder -> m (SourceSpan, Binder)
goBinder SourceSpan
_ e :: Binder
e@(PositionedBinder SourceSpan
pos [Comment]
_ Binder
_) = forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
pos, Binder
e)
  goBinder SourceSpan
pos (TypedBinder SourceType
ty Binder
b) = do
    SourceType
ty' <- SourceSpan -> SourceType -> m SourceType
goType' SourceSpan
pos SourceType
ty
    forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
pos, SourceType -> Binder -> Binder
TypedBinder SourceType
ty' Binder
b)
  goBinder SourceSpan
pos Binder
other = forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
pos, Binder
other)

-- |
-- Checks all the fixity exports within a module to ensure that members aliased
-- by the operators are also exported from the module.
--
-- This pass requires name desugaring and export elaboration to have run first.
--
checkFixityExports
  :: forall m
   . MonadError MultipleErrors m
  => Module
  -> m Module
checkFixityExports :: forall (m :: * -> *).
MonadError MultipleErrors m =>
Module -> m Module
checkFixityExports (Module SourceSpan
_ [Comment]
_ ModuleName
_ [Declaration]
_ Maybe [DeclarationRef]
Nothing) =
  forall a. HasCallStack => String -> a
internalError String
"exports should have been elaborated before checkFixityExports"
checkFixityExports m :: Module
m@(Module SourceSpan
ss [Comment]
_ ModuleName
mn [Declaration]
ds (Just [DeclarationRef]
exps)) =
  forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
rethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ModuleName -> ErrorMessageHint
ErrorInModule ModuleName
mn))
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> m a -> m a
rethrowWithPosition SourceSpan
ss (forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ DeclarationRef -> m ()
checkRef [DeclarationRef]
exps)
    forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Module
m
  where

  checkRef :: DeclarationRef -> m ()
  checkRef :: DeclarationRef -> m ()
checkRef dr :: DeclarationRef
dr@(ValueOpRef SourceSpan
ss' OpName 'ValueOpName
op) =
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (OpName 'ValueOpName
-> Maybe (Either Ident (ProperName 'ConstructorName))
getValueOpAlias OpName 'ValueOpName
op) forall a b. (a -> b) -> a -> b
$ \case
      Left Ident
ident ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SourceSpan -> Ident -> DeclarationRef
ValueRef SourceSpan
ss' Ident
ident forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DeclarationRef]
exps)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss'
          forall a b. (a -> b) -> a -> b
$ DeclarationRef -> [DeclarationRef] -> SimpleErrorMessage
TransitiveExportError DeclarationRef
dr [SourceSpan -> Ident -> DeclarationRef
ValueRef SourceSpan
ss' Ident
ident]
      Right ProperName 'ConstructorName
ctor ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (((ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
 -> Bool)
-> Bool
anyTypeRef (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ProperName 'ConstructorName
ctor) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd))
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss
          forall a b. (a -> b) -> a -> b
$ DeclarationRef
-> [ProperName 'ConstructorName] -> SimpleErrorMessage
TransitiveDctorExportError DeclarationRef
dr [ProperName 'ConstructorName
ctor]
  checkRef dr :: DeclarationRef
dr@(TypeOpRef SourceSpan
ss' OpName 'TypeOpName
op) =
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (OpName 'TypeOpName -> Maybe (ProperName 'TypeName)
getTypeOpAlias OpName 'TypeOpName
op) forall a b. (a -> b) -> a -> b
$ \ProperName 'TypeName
ty ->
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (((ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
 -> Bool)
-> Bool
anyTypeRef ((forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
ty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss'
        forall a b. (a -> b) -> a -> b
$ DeclarationRef -> [DeclarationRef] -> SimpleErrorMessage
TransitiveExportError DeclarationRef
dr [SourceSpan
-> ProperName 'TypeName
-> Maybe [ProperName 'ConstructorName]
-> DeclarationRef
TypeRef SourceSpan
ss' ProperName 'TypeName
ty forall a. Maybe a
Nothing]
  checkRef DeclarationRef
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- Finds the name associated with a type operator when that type is also
  -- defined in the current module.
  getTypeOpAlias :: OpName 'TypeOpName -> Maybe (ProperName 'TypeName)
  getTypeOpAlias :: OpName 'TypeOpName -> Maybe (ProperName 'TypeName)
getTypeOpAlias OpName 'TypeOpName
op =
    forall a. [a] -> Maybe a
listToMaybe (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) TypeFixity -> Maybe (ProperName 'TypeName)
go forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Declaration -> Maybe (Either ValueFixity TypeFixity)
getFixityDecl) [Declaration]
ds)
    where
    go :: TypeFixity -> Maybe (ProperName 'TypeName)
go (TypeFixity Fixity
_ (Qualified (ByModuleName ModuleName
mn') ProperName 'TypeName
ident) OpName 'TypeOpName
op')
      | ModuleName
mn forall a. Eq a => a -> a -> Bool
== ModuleName
mn' Bool -> Bool -> Bool
&& OpName 'TypeOpName
op forall a. Eq a => a -> a -> Bool
== OpName 'TypeOpName
op' = forall a. a -> Maybe a
Just ProperName 'TypeName
ident
    go TypeFixity
_ = forall a. Maybe a
Nothing

  -- Finds the value or data constructor associated with an operator when that
  -- declaration is also in the current module.
  getValueOpAlias
    :: OpName 'ValueOpName
    -> Maybe (Either Ident (ProperName 'ConstructorName))
  getValueOpAlias :: OpName 'ValueOpName
-> Maybe (Either Ident (ProperName 'ConstructorName))
getValueOpAlias OpName 'ValueOpName
op =
    forall a. [a] -> Maybe a
listToMaybe (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ValueFixity -> Maybe (Either Ident (ProperName 'ConstructorName))
go (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Declaration -> Maybe (Either ValueFixity TypeFixity)
getFixityDecl) [Declaration]
ds)
    where
    go :: ValueFixity -> Maybe (Either Ident (ProperName 'ConstructorName))
go (ValueFixity Fixity
_ (Qualified (ByModuleName ModuleName
mn') Either Ident (ProperName 'ConstructorName)
ident) OpName 'ValueOpName
op')
      | ModuleName
mn forall a. Eq a => a -> a -> Bool
== ModuleName
mn' Bool -> Bool -> Bool
&& OpName 'ValueOpName
op forall a. Eq a => a -> a -> Bool
== OpName 'ValueOpName
op' = forall a. a -> Maybe a
Just Either Ident (ProperName 'ConstructorName)
ident
    go ValueFixity
_ = forall a. Maybe a
Nothing

  -- Tests the exported `TypeRef` entries with a predicate.
  anyTypeRef
    :: ((ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -> Bool)
    -> Bool
  anyTypeRef :: ((ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
 -> Bool)
-> Bool
anyTypeRef (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -> Bool
f = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeclarationRef
-> Maybe
     (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
getTypeRef) [DeclarationRef]
exps

usingPredicate
  :: forall f a
   . Applicative f
  => (a -> Bool)
  -> (a -> f a)
  -> (a -> f a)
usingPredicate :: forall (f :: * -> *) a.
Applicative f =>
(a -> Bool) -> (a -> f a) -> a -> f a
usingPredicate a -> Bool
p a -> f a
f a
x =
  if a -> Bool
p a
x then a -> f a
f a
x else forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x