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
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
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)
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)
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
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)
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)
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 ()
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
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
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