module Language.PureScript.Sugar.BindingGroups
( createBindingGroups
, createBindingGroupsModule
, collapseBindingGroups
) where
import Prelude
import Protolude (ordNub, swap)
import Control.Monad ((<=<), guard)
import Control.Monad.Error.Class (MonadError(..))
import Data.Graph (SCC(..), stronglyConnComp, stronglyConnCompR)
import Data.List (intersect, (\\))
import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty)
import Data.Foldable (find)
import Data.Functor (($>))
import Data.Maybe (isJust, mapMaybe)
import Data.List.NonEmpty qualified as NEL
import Data.Map qualified as M
import Data.Set qualified as S
import Language.PureScript.AST
import Language.PureScript.Crash (internalError)
import Language.PureScript.Environment (NameKind)
import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors(..), SimpleErrorMessage(..), errorMessage', parU, positionedError)
import Language.PureScript.Names (pattern ByNullSourcePos, Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName)
import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), everythingOnTypes)
data VertexType
= VertexDefinition
| VertexKindSignature
| VertexRoleDeclaration
deriving (VertexType -> VertexType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VertexType -> VertexType -> Bool
$c/= :: VertexType -> VertexType -> Bool
== :: VertexType -> VertexType -> Bool
$c== :: VertexType -> VertexType -> Bool
Eq, Eq VertexType
VertexType -> VertexType -> Bool
VertexType -> VertexType -> Ordering
VertexType -> VertexType -> VertexType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: VertexType -> VertexType -> VertexType
$cmin :: VertexType -> VertexType -> VertexType
max :: VertexType -> VertexType -> VertexType
$cmax :: VertexType -> VertexType -> VertexType
>= :: VertexType -> VertexType -> Bool
$c>= :: VertexType -> VertexType -> Bool
> :: VertexType -> VertexType -> Bool
$c> :: VertexType -> VertexType -> Bool
<= :: VertexType -> VertexType -> Bool
$c<= :: VertexType -> VertexType -> Bool
< :: VertexType -> VertexType -> Bool
$c< :: VertexType -> VertexType -> Bool
compare :: VertexType -> VertexType -> Ordering
$ccompare :: VertexType -> VertexType -> Ordering
Ord, Int -> VertexType -> ShowS
[VertexType] -> ShowS
VertexType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VertexType] -> ShowS
$cshowList :: [VertexType] -> ShowS
show :: VertexType -> String
$cshow :: VertexType -> String
showsPrec :: Int -> VertexType -> ShowS
$cshowsPrec :: Int -> VertexType -> ShowS
Show)
createBindingGroupsModule
:: (MonadError MultipleErrors m)
=> Module
-> m Module
createBindingGroupsModule :: forall (m :: * -> *).
MonadError MultipleErrors m =>
Module -> m Module
createBindingGroupsModule (Module SourceSpan
ss [Comment]
coms ModuleName
name [Declaration]
ds Maybe [DeclarationRef]
exps) =
SourceSpan
-> [Comment]
-> ModuleName
-> [Declaration]
-> Maybe [DeclarationRef]
-> Module
Module SourceSpan
ss [Comment]
coms ModuleName
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadError MultipleErrors m =>
ModuleName -> [Declaration] -> m [Declaration]
createBindingGroups ModuleName
name [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]
exps
createBindingGroups
:: forall m
. (MonadError MultipleErrors m)
=> ModuleName
-> [Declaration]
-> m [Declaration]
createBindingGroups :: forall (m :: * -> *).
MonadError MultipleErrors m =>
ModuleName -> [Declaration] -> m [Declaration]
createBindingGroups ModuleName
moduleName = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Declaration -> m Declaration
f forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Declaration] -> m [Declaration]
handleDecls
where
(Declaration -> m Declaration
f, 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 (m :: * -> *) a. Monad m => a -> m a
return Expr -> m Expr
handleExprs forall (m :: * -> *) a. Monad m => a -> m a
return
handleExprs :: Expr -> m Expr
handleExprs :: Expr -> m Expr
handleExprs (Let WhereProvenance
w [Declaration]
ds Expr
val) = (\[Declaration]
ds' -> WhereProvenance -> [Declaration] -> Expr -> Expr
Let WhereProvenance
w [Declaration]
ds' Expr
val) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration] -> m [Declaration]
handleDecls [Declaration]
ds
handleExprs Expr
other = forall (m :: * -> *) a. Monad m => a -> m a
return Expr
other
handleDecls :: [Declaration] -> m [Declaration]
handleDecls :: [Declaration] -> m [Declaration]
handleDecls [Declaration]
ds = do
let values :: [ValueDeclarationData Expr]
values = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GuardedExpr] -> Expr
extractGuardedExpr) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> Maybe (ValueDeclarationData [GuardedExpr])
getValueDeclaration) [Declaration]
ds
kindDecls :: [(Declaration, VertexType)]
kindDecls = (,VertexType
VertexKindSignature) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter Declaration -> Bool
isKindDecl [Declaration]
ds
dataDecls :: [(Declaration, VertexType)]
dataDecls = (,VertexType
VertexDefinition) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (\Declaration
a -> Declaration -> Bool
isDataDecl Declaration
a Bool -> Bool -> Bool
|| Declaration -> Bool
isExternDataDecl Declaration
a Bool -> Bool -> Bool
|| Declaration -> Bool
isTypeSynonymDecl Declaration
a Bool -> Bool -> Bool
|| Declaration -> Bool
isTypeClassDecl Declaration
a) [Declaration]
ds
roleDecls :: [(Declaration, VertexType)]
roleDecls = (,VertexType
VertexRoleDeclaration) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter Declaration -> Bool
isRoleDecl [Declaration]
ds
roleAnns :: [ProperName 'TypeName]
roleAnns = Declaration -> ProperName 'TypeName
declTypeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Declaration, VertexType)]
roleDecls
kindSigs :: [ProperName 'TypeName]
kindSigs = Declaration -> ProperName 'TypeName
declTypeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Declaration, VertexType)]
kindDecls
typeSyns :: [ProperName 'TypeName]
typeSyns = Declaration -> ProperName 'TypeName
declTypeName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter Declaration -> Bool
isTypeSynonymDecl [Declaration]
ds
nonTypeSynKindSigs :: [ProperName 'TypeName]
nonTypeSynKindSigs = [ProperName 'TypeName]
kindSigs forall a. Eq a => [a] -> [a] -> [a]
\\ [ProperName 'TypeName]
typeSyns
allDecls :: [(Declaration, VertexType)]
allDecls = [(Declaration, VertexType)]
kindDecls forall a. [a] -> [a] -> [a]
++ [(Declaration, VertexType)]
dataDecls forall a. [a] -> [a] -> [a]
++ [(Declaration, VertexType)]
roleDecls
allProperNames :: [ProperName 'TypeName]
allProperNames = Declaration -> ProperName 'TypeName
declTypeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Declaration, VertexType)]
allDecls
mkVert :: (Declaration, VertexType)
-> (Declaration, (ProperName 'TypeName, VertexType),
[(ProperName 'TypeName, VertexType)])
mkVert (Declaration
d, VertexType
vty) =
let names :: [ProperName 'TypeName]
names = ModuleName -> Declaration -> [ProperName 'TypeName]
usedTypeNames ModuleName
moduleName Declaration
d forall a. Eq a => [a] -> [a] -> [a]
`intersect` [ProperName 'TypeName]
allProperNames
name :: ProperName 'TypeName
name = Declaration -> ProperName 'TypeName
declTypeName Declaration
d
vtype :: ProperName 'TypeName -> VertexType
vtype ProperName 'TypeName
n
| VertexType
vty forall a. Eq a => a -> a -> Bool
== VertexType
VertexKindSignature Bool -> Bool -> Bool
&& ProperName 'TypeName
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ProperName 'TypeName]
nonTypeSynKindSigs = VertexType
VertexKindSignature
| Bool
otherwise = VertexType
VertexDefinition
deps :: [(ProperName 'TypeName, VertexType)]
deps = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ProperName 'TypeName
n -> (ProperName 'TypeName
n, ProperName 'TypeName -> VertexType
vtype ProperName 'TypeName
n)) [ProperName 'TypeName]
names
self :: [(ProperName 'TypeName, VertexType)]
self
| VertexType
vty forall a. Eq a => a -> a -> Bool
== VertexType
VertexDefinition =
(forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ProperName 'TypeName
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ProperName 'TypeName]
kindSigs) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ProperName 'TypeName
name, VertexType
VertexKindSignature))
forall a. [a] -> [a] -> [a]
++ (forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ProperName 'TypeName
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ProperName 'TypeName]
roleAnns Bool -> Bool -> Bool
&& Bool -> Bool
not (Declaration -> Bool
isExternDataDecl Declaration
d)) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ProperName 'TypeName
name, VertexType
VertexRoleDeclaration))
| VertexType
vty forall a. Eq a => a -> a -> Bool
== VertexType
VertexRoleDeclaration = [(ProperName 'TypeName
name, VertexType
VertexDefinition)]
| Bool
otherwise = []
in (Declaration
d, (ProperName 'TypeName
name, VertexType
vty), [(ProperName 'TypeName, VertexType)]
self forall a. [a] -> [a] -> [a]
++ [(ProperName 'TypeName, VertexType)]
deps)
dataVerts :: [(Declaration, (ProperName 'TypeName, VertexType),
[(ProperName 'TypeName, VertexType)])]
dataVerts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Declaration, VertexType)
-> (Declaration, (ProperName 'TypeName, VertexType),
[(ProperName 'TypeName, VertexType)])
mkVert [(Declaration, VertexType)]
allDecls
[Declaration]
dataBindingGroupDecls <- forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU (forall key node.
Ord key =>
[(node, key, [key])] -> [SCC (node, key, [key])]
stronglyConnCompR [(Declaration, (ProperName 'TypeName, VertexType),
[(ProperName 'TypeName, VertexType)])]
dataVerts) forall (m :: * -> *) a.
(MonadError MultipleErrors m, Ord a) =>
SCC
(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])
-> m Declaration
toDataBindingGroup
let
makeValueDeclarationKey :: ValueDeclarationData Expr -> (Bool, Ident)
makeValueDeclarationKey = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Bool
exprHasNoTypeHole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ValueDeclarationData a -> a
valdeclExpression forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. ValueDeclarationData a -> Ident
valdeclIdent
valueDeclarationKeys :: [(Bool, Ident)]
valueDeclarationKeys = ValueDeclarationData Expr -> (Bool, Ident)
makeValueDeclarationKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ValueDeclarationData Expr]
values
valueDeclarationInfo :: Map Ident Bool
valueDeclarationInfo = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> (b, a)
swap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Bool, Ident)]
valueDeclarationKeys
findDeclarationInfo :: Ident -> (Bool, Ident)
findDeclarationInfo Ident
i = (forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Bool
False Ident
i Map Ident Bool
valueDeclarationInfo, Ident
i)
computeValueDependencies :: ValueDeclarationData Expr -> [(Bool, Ident)]
computeValueDependencies = (forall a. Eq a => [a] -> [a] -> [a]
`intersect` [(Bool, Ident)]
valueDeclarationKeys) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ident -> (Bool, Ident)
findDeclarationInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> ValueDeclarationData Expr -> [Ident]
usedIdents ModuleName
moduleName
makeValueDeclarationVert :: ValueDeclarationData Expr
-> (ValueDeclarationData Expr, (Bool, Ident), [(Bool, Ident)])
makeValueDeclarationVert = (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> a
id forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ValueDeclarationData Expr -> (Bool, Ident)
makeValueDeclarationKey forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ValueDeclarationData Expr -> [(Bool, Ident)]
computeValueDependencies
valueDeclarationVerts :: [(ValueDeclarationData Expr, (Bool, Ident), [(Bool, Ident)])]
valueDeclarationVerts = ValueDeclarationData Expr
-> (ValueDeclarationData Expr, (Bool, Ident), [(Bool, Ident)])
makeValueDeclarationVert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ValueDeclarationData Expr]
values
[Declaration]
bindingGroupDecls <- forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU (forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [(ValueDeclarationData Expr, (Bool, Ident), [(Bool, Ident)])]
valueDeclarationVerts) (forall (m :: * -> *).
MonadError MultipleErrors m =>
ModuleName -> SCC (ValueDeclarationData Expr) -> m Declaration
toBindingGroup ModuleName
moduleName)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Declaration -> Bool
isImportDecl [Declaration]
ds forall a. [a] -> [a] -> [a]
++
[Declaration]
dataBindingGroupDecls forall a. [a] -> [a] -> [a]
++
forall a. (a -> Bool) -> [a] -> [a]
filter Declaration -> Bool
isTypeClassInstanceDecl [Declaration]
ds forall a. [a] -> [a] -> [a]
++
forall a. (a -> Bool) -> [a] -> [a]
filter Declaration -> Bool
isFixityDecl [Declaration]
ds forall a. [a] -> [a] -> [a]
++
forall a. (a -> Bool) -> [a] -> [a]
filter Declaration -> Bool
isExternDecl [Declaration]
ds forall a. [a] -> [a] -> [a]
++
[Declaration]
bindingGroupDecls
where
extractGuardedExpr :: [GuardedExpr] -> Expr
extractGuardedExpr [MkUnguarded Expr
expr] = Expr
expr
extractGuardedExpr [GuardedExpr]
_ = forall a. HasCallStack => String -> a
internalError String
"Expected Guards to have been desugared in handleDecls."
exprHasNoTypeHole :: Expr -> Bool
exprHasNoTypeHole :: Expr -> Bool
exprHasNoTypeHole = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Bool
exprHasTypeHole
where
exprHasTypeHole :: Expr -> Bool
(Declaration -> Bool
_, Expr -> Bool
exprHasTypeHole, Binder -> Bool
_, CaseAlternative -> Bool
_, DoNotationElement -> Bool
_) = forall r.
(r -> r -> r)
-> (Declaration -> r)
-> (Expr -> r)
-> (Binder -> r)
-> (CaseAlternative -> r)
-> (DoNotationElement -> r)
-> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r,
DoNotationElement -> r)
everythingOnValues Bool -> Bool -> Bool
(||) forall a. a -> Bool
goDefault Expr -> Bool
goExpr forall a. a -> Bool
goDefault forall a. a -> Bool
goDefault forall a. a -> Bool
goDefault
where
goExpr :: Expr -> Bool
goExpr :: Expr -> Bool
goExpr (Hole Text
_) = Bool
True
goExpr Expr
_ = Bool
False
goDefault :: forall a. a -> Bool
goDefault :: forall a. a -> Bool
goDefault = forall a b. a -> b -> a
const Bool
False
collapseBindingGroups :: [Declaration] -> [Declaration]
collapseBindingGroups :: [Declaration] -> [Declaration]
collapseBindingGroups =
let (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
flattenBindingGroupsForValue forall a. a -> a
id
in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Declaration -> Declaration
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Declaration] -> [Declaration]
flattenBindingGroups
flattenBindingGroupsForValue :: Expr -> Expr
flattenBindingGroupsForValue :: Expr -> Expr
flattenBindingGroupsForValue (Let WhereProvenance
w [Declaration]
ds Expr
val) = WhereProvenance -> [Declaration] -> Expr -> Expr
Let WhereProvenance
w ([Declaration] -> [Declaration]
flattenBindingGroups [Declaration]
ds) Expr
val
flattenBindingGroupsForValue Expr
other = Expr
other
flattenBindingGroups :: [Declaration] -> [Declaration]
flattenBindingGroups :: [Declaration] -> [Declaration]
flattenBindingGroups = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [Declaration]
go
where
go :: Declaration -> [Declaration]
go (DataBindingGroupDeclaration NonEmpty Declaration
ds) = forall a. NonEmpty a -> [a]
NEL.toList NonEmpty Declaration
ds
go (BindingGroupDeclaration NonEmpty ((SourceAnn, Ident), NameKind, Expr)
ds) =
forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((SourceAnn
sa, Ident
ident), NameKind
nameKind, Expr
val) ->
SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl SourceAnn
sa Ident
ident NameKind
nameKind [] [Expr -> GuardedExpr
MkUnguarded Expr
val]) NonEmpty ((SourceAnn, Ident), NameKind, Expr)
ds
go Declaration
other = [Declaration
other]
usedIdents :: ModuleName -> ValueDeclarationData Expr -> [Ident]
usedIdents :: ModuleName -> ValueDeclarationData Expr -> [Ident]
usedIdents ModuleName
moduleName = forall a. Ord a => [a] -> [a]
ordNub forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ScopedIdent -> Expr -> [Ident]
usedIdents' forall a. Set a
S.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ValueDeclarationData a -> a
valdeclExpression
where
def :: p -> p -> [a]
def p
_ p
_ = []
(Set ScopedIdent -> Declaration -> [Ident]
_, Set ScopedIdent -> Expr -> [Ident]
usedIdents', Set ScopedIdent -> Binder -> [Ident]
_, Set ScopedIdent -> CaseAlternative -> [Ident]
_, Set ScopedIdent -> DoNotationElement -> [Ident]
_) = forall r.
Monoid r =>
(Set ScopedIdent -> Declaration -> r)
-> (Set ScopedIdent -> Expr -> r)
-> (Set ScopedIdent -> Binder -> r)
-> (Set ScopedIdent -> CaseAlternative -> r)
-> (Set ScopedIdent -> DoNotationElement -> r)
-> (Set ScopedIdent -> Declaration -> r,
Set ScopedIdent -> Expr -> r, Set ScopedIdent -> Binder -> r,
Set ScopedIdent -> CaseAlternative -> r,
Set ScopedIdent -> DoNotationElement -> r)
everythingWithScope forall {p} {p} {a}. p -> p -> [a]
def Set ScopedIdent -> Expr -> [Ident]
usedNamesE forall {p} {p} {a}. p -> p -> [a]
def forall {p} {p} {a}. p -> p -> [a]
def forall {p} {p} {a}. p -> p -> [a]
def
usedNamesE :: S.Set ScopedIdent -> Expr -> [Ident]
usedNamesE :: Set ScopedIdent -> Expr -> [Ident]
usedNamesE Set ScopedIdent
scope (Var SourceSpan
_ (Qualified (BySourcePos SourcePos
_) Ident
name))
| Ident -> ScopedIdent
LocalIdent Ident
name forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set ScopedIdent
scope = [Ident
name]
usedNamesE Set ScopedIdent
scope (Var SourceSpan
_ (Qualified (ByModuleName ModuleName
moduleName') Ident
name))
| ModuleName
moduleName forall a. Eq a => a -> a -> Bool
== ModuleName
moduleName' Bool -> Bool -> Bool
&& Ident -> ScopedIdent
ToplevelIdent Ident
name forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set ScopedIdent
scope = [Ident
name]
usedNamesE Set ScopedIdent
_ Expr
_ = []
usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
usedImmediateIdents ModuleName
moduleName =
let (Declaration -> [Ident]
f, Expr -> [Ident]
_, Binder -> [Ident]
_, CaseAlternative -> [Ident]
_, DoNotationElement -> [Ident]
_) = forall s r.
s
-> r
-> (r -> r -> r)
-> (s -> Declaration -> (s, r))
-> (s -> Expr -> (s, r))
-> (s -> Binder -> (s, r))
-> (s -> CaseAlternative -> (s, r))
-> (s -> DoNotationElement -> (s, r))
-> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r,
DoNotationElement -> r)
everythingWithContextOnValues Bool
True [] forall a. [a] -> [a] -> [a]
(++) forall {a} {p} {a}. a -> p -> (a, [a])
def Bool -> Expr -> (Bool, [Ident])
usedNamesE forall {a} {p} {a}. a -> p -> (a, [a])
def forall {a} {p} {a}. a -> p -> (a, [a])
def forall {a} {p} {a}. a -> p -> (a, [a])
def
in forall a. Ord a => [a] -> [a]
ordNub forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> [Ident]
f
where
def :: a -> p -> (a, [a])
def a
s p
_ = (a
s, [])
usedNamesE :: Bool -> Expr -> (Bool, [Ident])
usedNamesE :: Bool -> Expr -> (Bool, [Ident])
usedNamesE Bool
True (Var SourceSpan
_ (Qualified (BySourcePos SourcePos
_) Ident
name)) = (Bool
True, [Ident
name])
usedNamesE Bool
True (Var SourceSpan
_ (Qualified (ByModuleName ModuleName
moduleName') Ident
name))
| ModuleName
moduleName forall a. Eq a => a -> a -> Bool
== ModuleName
moduleName' = (Bool
True, [Ident
name])
usedNamesE Bool
True (Abs Binder
_ Expr
_) = (Bool
False, [])
usedNamesE Bool
scope Expr
_ = (Bool
scope, [])
usedTypeNames :: ModuleName -> Declaration -> [ProperName 'TypeName]
usedTypeNames :: ModuleName -> Declaration -> [ProperName 'TypeName]
usedTypeNames ModuleName
moduleName = Declaration -> [ProperName 'TypeName]
go
where
(Declaration -> [ProperName 'TypeName]
f, Expr -> [ProperName 'TypeName]
_, Binder -> [ProperName 'TypeName]
_, CaseAlternative -> [ProperName 'TypeName]
_, DoNotationElement -> [ProperName 'TypeName]
_) = forall r.
Monoid r =>
(SourceType -> r)
-> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r,
DoNotationElement -> r)
accumTypes (forall r a. (r -> r -> r) -> (Type a -> r) -> Type a -> r
everythingOnTypes forall a. [a] -> [a] -> [a]
(++) SourceType -> [ProperName 'TypeName]
usedNames)
go :: Declaration -> [ProperName 'TypeName]
go :: Declaration -> [ProperName 'TypeName]
go Declaration
decl = forall a. Ord a => [a] -> [a]
ordNub (Declaration -> [ProperName 'TypeName]
f Declaration
decl forall a. Semigroup a => a -> a -> a
<> Declaration -> [ProperName 'TypeName]
usedNamesForTypeClassDeps Declaration
decl)
usedNames :: SourceType -> [ProperName 'TypeName]
usedNames :: SourceType -> [ProperName 'TypeName]
usedNames (ConstrainedType SourceAnn
_ Constraint SourceAnn
con SourceType
_) = Constraint SourceAnn -> [ProperName 'TypeName]
usedConstraint Constraint SourceAnn
con
usedNames (TypeConstructor SourceAnn
_ (Qualified (ByModuleName ModuleName
moduleName') ProperName 'TypeName
name))
| ModuleName
moduleName forall a. Eq a => a -> a -> Bool
== ModuleName
moduleName' = [ProperName 'TypeName
name]
usedNames SourceType
_ = []
usedConstraint :: SourceConstraint -> [ProperName 'TypeName]
usedConstraint :: Constraint SourceAnn -> [ProperName 'TypeName]
usedConstraint (Constraint SourceAnn
_ (Qualified (ByModuleName ModuleName
moduleName') ProperName 'ClassName
name) [SourceType]
_ [SourceType]
_ Maybe ConstraintData
_)
| ModuleName
moduleName forall a. Eq a => a -> a -> Bool
== ModuleName
moduleName' = [forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'ClassName
name]
usedConstraint Constraint SourceAnn
_ = []
usedNamesForTypeClassDeps :: Declaration -> [ProperName 'TypeName]
usedNamesForTypeClassDeps :: Declaration -> [ProperName 'TypeName]
usedNamesForTypeClassDeps (TypeClassDeclaration SourceAnn
_ ProperName 'ClassName
_ [(Text, Maybe SourceType)]
_ [Constraint SourceAnn]
deps [FunctionalDependency]
_ [Declaration]
_) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Constraint SourceAnn -> [ProperName 'TypeName]
usedConstraint [Constraint SourceAnn]
deps
usedNamesForTypeClassDeps Declaration
_ = []
declTypeName :: Declaration -> ProperName 'TypeName
declTypeName :: Declaration -> ProperName 'TypeName
declTypeName (DataDeclaration SourceAnn
_ DataDeclType
_ ProperName 'TypeName
pn [(Text, Maybe SourceType)]
_ [DataConstructorDeclaration]
_) = ProperName 'TypeName
pn
declTypeName (ExternDataDeclaration SourceAnn
_ ProperName 'TypeName
pn SourceType
_) = ProperName 'TypeName
pn
declTypeName (TypeSynonymDeclaration SourceAnn
_ ProperName 'TypeName
pn [(Text, Maybe SourceType)]
_ SourceType
_) = ProperName 'TypeName
pn
declTypeName (TypeClassDeclaration SourceAnn
_ ProperName 'ClassName
pn [(Text, Maybe SourceType)]
_ [Constraint SourceAnn]
_ [FunctionalDependency]
_ [Declaration]
_) = forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName ProperName 'ClassName
pn
declTypeName (KindDeclaration SourceAnn
_ KindSignatureFor
_ ProperName 'TypeName
pn SourceType
_) = ProperName 'TypeName
pn
declTypeName (RoleDeclaration (RoleDeclarationData SourceAnn
_ ProperName 'TypeName
pn [Role]
_)) = ProperName 'TypeName
pn
declTypeName Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"Expected DataDeclaration"
toBindingGroup
:: forall m
. (MonadError MultipleErrors m)
=> ModuleName
-> SCC (ValueDeclarationData Expr)
-> m Declaration
toBindingGroup :: forall (m :: * -> *).
MonadError MultipleErrors m =>
ModuleName -> SCC (ValueDeclarationData Expr) -> m Declaration
toBindingGroup ModuleName
_ (AcyclicSCC ValueDeclarationData Expr
d) = forall (m :: * -> *) a. Monad m => a -> m a
return (ValueDeclarationData Expr -> Declaration
mkDeclaration ValueDeclarationData Expr
d)
toBindingGroup ModuleName
moduleName (CyclicSCC [ValueDeclarationData Expr]
ds') = do
NonEmpty ((SourceAnn, Ident), NameKind, Expr) -> Declaration
BindingGroupDeclaration forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> NonEmpty a
NEL.fromList 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 SCC (ValueDeclarationData Expr)
-> m ((SourceAnn, Ident), NameKind, Expr)
toBinding (forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [(ValueDeclarationData Expr, Ident, [Ident])]
valueVerts)
where
idents :: [Ident]
idents :: [Ident]
idents = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ValueDeclarationData Expr
_, Ident
i, [Ident]
_) -> Ident
i) [(ValueDeclarationData Expr, Ident, [Ident])]
valueVerts
valueVerts :: [(ValueDeclarationData Expr, Ident, [Ident])]
valueVerts :: [(ValueDeclarationData Expr, Ident, [Ident])]
valueVerts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ValueDeclarationData Expr
d -> (ValueDeclarationData Expr
d, forall a. ValueDeclarationData a -> Ident
valdeclIdent ValueDeclarationData Expr
d, ModuleName -> Declaration -> [Ident]
usedImmediateIdents ModuleName
moduleName (ValueDeclarationData Expr -> Declaration
mkDeclaration ValueDeclarationData Expr
d) forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Ident]
idents)) [ValueDeclarationData Expr]
ds'
toBinding :: SCC (ValueDeclarationData Expr) -> m ((SourceAnn, Ident), NameKind, Expr)
toBinding :: SCC (ValueDeclarationData Expr)
-> m ((SourceAnn, Ident), NameKind, Expr)
toBinding (AcyclicSCC ValueDeclarationData Expr
d) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ValueDeclarationData Expr -> ((SourceAnn, Ident), NameKind, Expr)
fromValueDecl ValueDeclarationData Expr
d
toBinding (CyclicSCC [ValueDeclarationData Expr]
ds) = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ValueDeclarationData Expr -> MultipleErrors
cycleError [ValueDeclarationData Expr]
ds
cycleError :: ValueDeclarationData Expr -> MultipleErrors
cycleError :: ValueDeclarationData Expr -> MultipleErrors
cycleError (ValueDeclarationData (SourceSpan
ss, [Comment]
_) Ident
n NameKind
_ [Binder]
_ Expr
_) = SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
CycleInDeclaration Ident
n
toDataBindingGroup
:: MonadError MultipleErrors m
=> Ord a
=> SCC (Declaration, (ProperName 'TypeName, a), [(ProperName 'TypeName, a)])
-> m Declaration
toDataBindingGroup :: forall (m :: * -> *) a.
(MonadError MultipleErrors m, Ord a) =>
SCC
(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])
-> m Declaration
toDataBindingGroup (AcyclicSCC (Declaration
d, (ProperName 'TypeName, a)
_, [(ProperName 'TypeName, a)]
_)) = forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d
toDataBindingGroup (CyclicSCC [(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])]
ds')
| Just kds :: NonEmpty (SourceSpan, Qualified (ProperName 'TypeName))
kds@((SourceSpan
ss, Qualified (ProperName 'TypeName)
_):|[(SourceSpan, Qualified (ProperName 'TypeName))]
_) <- forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Declaration -> [(SourceSpan, Qualified (ProperName 'TypeName))]
kindDecl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> a
getDecl) [(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])]
ds' = 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 b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Qualified (ProperName 'TypeName)) -> SimpleErrorMessage
CycleInKindDeclaration forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd NonEmpty (SourceSpan, Qualified (ProperName 'TypeName))
kds
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NonEmpty
(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])]
typeSynonymCycles) =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ErrorMessage] -> MultipleErrors
MultipleErrors
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NonEmpty
(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])
syns -> [ErrorMessageHint] -> SimpleErrorMessage -> ErrorMessage
ErrorMessage [SourceSpan -> ErrorMessageHint
positionedError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> SourceSpan
declSourceSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> a
getDecl forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NEL.head NonEmpty
(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])
syns] forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ProperName 'TypeName) -> SimpleErrorMessage
CycleInTypeSynonym forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> b
getName) NonEmpty
(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])
syns)
forall a b. (a -> b) -> a -> b
$ [NonEmpty
(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])]
typeSynonymCycles
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Declaration -> Declaration
DataBindingGroupDeclaration forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> NonEmpty a
NEL.fromList forall a b. (a -> b) -> a -> b
$ forall {a} {b} {c}. (a, b, c) -> a
getDecl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])]
ds'
where
kindDecl :: Declaration -> [(SourceSpan, Qualified (ProperName 'TypeName))]
kindDecl (KindDeclaration SourceAnn
sa KindSignatureFor
_ ProperName 'TypeName
pn SourceType
_) = [(forall a b. (a, b) -> a
fst SourceAnn
sa, forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos ProperName 'TypeName
pn)]
kindDecl (ExternDataDeclaration SourceAnn
sa ProperName 'TypeName
pn SourceType
_) = [(forall a b. (a, b) -> a
fst SourceAnn
sa, forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos ProperName 'TypeName
pn)]
kindDecl Declaration
_ = []
getDecl :: (a, b, c) -> a
getDecl (a
decl, b
_, c
_) = a
decl
getName :: (a, b, c) -> b
getName (a
_, b
name, c
_) = b
name
lookupVert :: (ProperName 'TypeName, a)
-> Maybe
(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])
lookupVert (ProperName 'TypeName, a)
name = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
(==) (ProperName 'TypeName, a)
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> b
getName) [(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])]
ds'
onlySynonyms :: (Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])
-> Maybe
(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])
onlySynonyms (Declaration
decl, (ProperName 'TypeName, a)
name, [(ProperName 'TypeName, a)]
deps) = do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Declaration -> Maybe (ProperName 'TypeName)
isTypeSynonym Declaration
decl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Declaration
decl, (ProperName 'TypeName, a)
name, forall a. (a -> Bool) -> [a] -> [a]
filter (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> Maybe (ProperName 'TypeName)
isTypeSynonym forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> a
getDecl) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProperName 'TypeName, a)
-> Maybe
(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])
lookupVert) [(ProperName 'TypeName, a)]
deps)
isCycle :: SCC a -> Maybe (NonEmpty a)
isCycle (CyclicSCC [a]
c) = forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [a]
c
isCycle SCC a
_ = forall a. Maybe a
Nothing
typeSynonymCycles :: [NonEmpty
(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])]
typeSynonymCycles =
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. SCC a -> Maybe (NonEmpty a)
isCycle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key node.
Ord key =>
[(node, key, [key])] -> [SCC (node, key, [key])]
stronglyConnCompR forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])
-> Maybe
(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])
onlySynonyms forall a b. (a -> b) -> a -> b
$ [(Declaration, (ProperName 'TypeName, a),
[(ProperName 'TypeName, a)])]
ds'
isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName)
isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName)
isTypeSynonym (TypeSynonymDeclaration SourceAnn
_ ProperName 'TypeName
pn [(Text, Maybe SourceType)]
_ SourceType
_) = forall a. a -> Maybe a
Just ProperName 'TypeName
pn
isTypeSynonym Declaration
_ = forall a. Maybe a
Nothing
mkDeclaration :: ValueDeclarationData Expr -> Declaration
mkDeclaration :: ValueDeclarationData Expr -> Declaration
mkDeclaration = ValueDeclarationData [GuardedExpr] -> Declaration
ValueDeclaration forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> GuardedExpr
MkUnguarded)
fromValueDecl :: ValueDeclarationData Expr -> ((SourceAnn, Ident), NameKind, Expr)
fromValueDecl :: ValueDeclarationData Expr -> ((SourceAnn, Ident), NameKind, Expr)
fromValueDecl (ValueDeclarationData SourceAnn
sa Ident
ident NameKind
nameKind [] Expr
val) = ((SourceAnn
sa, Ident
ident), NameKind
nameKind, Expr
val)
fromValueDecl ValueDeclarationData{} = forall a. HasCallStack => String -> a
internalError String
"Binders should have been desugared"