-- |
-- 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
import Language.PureScript.Errors
import Language.PureScript.Externs
import Language.PureScript.Names
import Language.PureScript.Sugar.Operators.Binders
import Language.PureScript.Sugar.Operators.Expr
import Language.PureScript.Sugar.Operators.Types
import Language.PureScript.Traversals (defS, sndM)
import Language.PureScript.Types

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 qualified Data.Map as M
import Data.Ord (Down(..))

import qualified Language.PureScript.Constants.Libs 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