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
import Data.List (intersect, (\\))
import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty)
import Data.Foldable (find)
import Data.Functor (($>))
import Data.Maybe (isJust, mapMaybe)
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import qualified Data.Set as S
import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Errors hiding (nonEmpty)
import Language.PureScript.Names
import Language.PureScript.Types
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"