module Language.PureScript.CoreFn.Laziness
( applyLazinessTransform
) where
import Protolude hiding (force)
import Protolude.Unsafe (unsafeHead)
import Control.Arrow ((&&&))
import Data.Array qualified as A
import Data.Coerce (coerce)
import Data.Graph (SCC(..), stronglyConnComp)
import Data.List (foldl1', (!!))
import Data.IntMap.Monoidal qualified as IM
import Data.IntSet qualified as IS
import Data.Map.Monoidal qualified as M
import Data.Semigroup (Max(..))
import Data.Set qualified as S
import Language.PureScript.AST.SourcePos (SourcePos(..), SourceSpan(..), nullSourceSpan)
import Language.PureScript.Constants.Libs qualified as C
import Language.PureScript.CoreFn (Ann, Bind, Expr(..), Literal(..), Meta(..), ssAnn, traverseCoreFn)
import Language.PureScript.Crash (internalError)
import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), InternalIdentData(..), ModuleName, Qualified(..), QualifiedBy(..), runIdent, runModuleName, toMaybeModuleName)
import Language.PureScript.PSString (mkString)
onVarsWithDelayAndForce :: forall f. Applicative f => (Int -> Maybe Int -> Ann -> Qualified Ident -> f (Expr Ann)) -> Expr Ann -> f (Expr Ann)
onVarsWithDelayAndForce :: forall (f :: * -> *).
Applicative f =>
(Int -> Maybe Int -> Ann -> Qualified Ident -> f (Expr Ann))
-> Expr Ann -> f (Expr Ann)
onVarsWithDelayAndForce Int -> Maybe Int -> Ann -> Qualified Ident -> f (Expr Ann)
f = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Maybe Int
-> (Bind Ann -> f (Bind Ann), Expr Ann -> f (Expr Ann))
go Int
0 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
0
where
go :: Int -> Maybe Int -> (Bind Ann -> f (Bind Ann), Expr Ann -> f (Expr Ann))
go :: Int
-> Maybe Int
-> (Bind Ann -> f (Bind Ann), Expr Ann -> f (Expr Ann))
go Int
delay Maybe Int
force = (Bind Ann -> f (Bind Ann)
handleBind, Expr Ann -> f (Expr Ann)
handleExpr')
where
(Bind Ann -> f (Bind Ann)
handleBind, Expr Ann -> f (Expr Ann)
handleExpr, Binder Ann -> f (Binder Ann)
handleBinder, CaseAlternative Ann -> f (CaseAlternative Ann)
handleCaseAlternative) = forall (f :: * -> *) a.
Applicative f =>
(Bind a -> f (Bind a))
-> (Expr a -> f (Expr a))
-> (Binder a -> f (Binder a))
-> (CaseAlternative a -> f (CaseAlternative a))
-> (Bind a -> f (Bind a), Expr a -> f (Expr a),
Binder a -> f (Binder a),
CaseAlternative a -> f (CaseAlternative a))
traverseCoreFn Bind Ann -> f (Bind Ann)
handleBind Expr Ann -> f (Expr Ann)
handleExpr' Binder Ann -> f (Binder Ann)
handleBinder CaseAlternative Ann -> f (CaseAlternative Ann)
handleCaseAlternative
handleExpr' :: Expr Ann -> f (Expr Ann)
handleExpr' = \case
Var Ann
a Qualified Ident
i -> Int -> Maybe Int -> Ann -> Qualified Ident -> f (Expr Ann)
f Int
delay Maybe Int
force Ann
a Qualified Ident
i
Abs Ann
a Ident
i Expr Ann
e -> forall a. a -> Ident -> Expr a -> Expr a
Abs Ann
a Ident
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a, b) -> b
snd (if Maybe Int
force forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Int
0 then Int
-> Maybe Int
-> (Bind Ann -> f (Bind Ann), Expr Ann -> f (Expr Ann))
go (forall a. Enum a => a -> a
succ Int
delay) Maybe Int
force else Int
-> Maybe Int
-> (Bind Ann -> f (Bind Ann), Expr Ann -> f (Expr Ann))
go Int
delay forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Enum a => a -> a
pred Maybe Int
force) Expr Ann
e
App Ann
a1 e1 :: Expr Ann
e1@(Var Ann
_ Qualified Ident
C.I_unsafePartial) (Abs Ann
a2 Ident
i Expr Ann
e2) -> forall a. a -> Expr a -> Expr a -> Expr a
App Ann
a1 Expr Ann
e1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Ident -> Expr a -> Expr a
Abs Ann
a2 Ident
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> f (Expr Ann)
handleExpr' Expr Ann
e2
App Ann
a Expr Ann
e1 Expr Ann
e2 ->
Int -> [(Ann, Expr Ann)] -> Expr Ann -> f (Expr Ann)
handleApp Int
1 [(Ann
a, Expr Ann
e2)] Expr Ann
e1
Case Ann
a [Expr Ann]
vs [CaseAlternative Ann]
alts -> forall a. a -> [Expr a] -> [CaseAlternative a] -> Expr a
Case Ann
a 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 a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Int
-> Maybe Int
-> (Bind Ann -> f (Bind Ann), Expr Ann -> f (Expr Ann))
go Int
delay forall a. Maybe a
Nothing) [Expr Ann]
vs 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 CaseAlternative Ann -> f (CaseAlternative Ann)
handleCaseAlternative [CaseAlternative Ann]
alts
Let Ann
a [Bind Ann]
ds Expr Ann
e -> forall a. a -> [Bind a] -> Expr a -> Expr a
Let Ann
a 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 a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Int
-> Maybe Int
-> (Bind Ann -> f (Bind Ann), Expr Ann -> f (Expr Ann))
go Int
delay forall a. Maybe a
Nothing) [Bind Ann]
ds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr Ann -> f (Expr Ann)
handleExpr' Expr Ann
e
Expr Ann
other -> Expr Ann -> f (Expr Ann)
handleExpr Expr Ann
other
handleApp :: Int -> [(Ann, Expr Ann)] -> Expr Ann -> f (Expr Ann)
handleApp Int
len [(Ann, Expr Ann)]
args = \case
App Ann
a Expr Ann
e1 Expr Ann
e2 -> Int -> [(Ann, Expr Ann)] -> Expr Ann -> f (Expr Ann)
handleApp (Int
len forall a. Num a => a -> a -> a
+ Int
1) ((Ann
a, Expr Ann
e2) forall a. a -> [a] -> [a]
: [(Ann, Expr Ann)]
args) Expr Ann
e1
Var a :: Ann
a@(SourceSpan
_, [Comment]
_, Maybe SourceType
_, Just Meta
meta) Qualified Ident
i | Meta -> Bool
isConstructorLike Meta
meta
-> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\f (Expr Ann)
e1 (Ann
a2, Expr Ann
e2) -> forall a. a -> Expr a -> Expr a -> Expr a
App Ann
a2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Expr Ann)
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr Ann -> f (Expr Ann)
handleExpr' Expr Ann
e2) (Int -> Maybe Int -> Ann -> Qualified Ident -> f (Expr Ann)
f Int
delay Maybe Int
force Ann
a Qualified Ident
i) [(Ann, Expr Ann)]
args
Expr Ann
e -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\f (Expr Ann)
e1 (Ann
a2, Expr Ann
e2) -> forall a. a -> Expr a -> Expr a -> Expr a
App Ann
a2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Expr Ann)
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a b. (a, b) -> b
snd (Int
-> Maybe Int
-> (Bind Ann -> f (Bind Ann), Expr Ann -> f (Expr Ann))
go Int
delay forall a. Maybe a
Nothing) Expr Ann
e2) (forall a b. (a, b) -> b
snd (Int
-> Maybe Int
-> (Bind Ann -> f (Bind Ann), Expr Ann -> f (Expr Ann))
go Int
delay (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ Int
len) Maybe Int
force)) Expr Ann
e) [(Ann, Expr Ann)]
args
isConstructorLike :: Meta -> Bool
isConstructorLike = \case
IsConstructor{} -> Bool
True
Meta
IsNewtype -> Bool
True
Meta
_ -> Bool
False
type MaxRoseTree m a = m (IM.MonoidalIntMap (MaxRoseNode m a))
data MaxRoseNode m a = MaxRoseNode a (MaxRoseTree m a)
instance Ord a => Semigroup (MaxRoseNode m a) where
l :: MaxRoseNode m a
l@(MaxRoseNode a
l1 MaxRoseTree m a
_) <> :: MaxRoseNode m a -> MaxRoseNode m a -> MaxRoseNode m a
<> r :: MaxRoseNode m a
r@(MaxRoseNode a
r1 MaxRoseTree m a
_) = if a
r1 forall a. Ord a => a -> a -> Bool
> a
l1 then MaxRoseNode m a
r else MaxRoseNode m a
l
mrtFlatten :: (Monad m, Ord a) => MaxRoseTree m a -> m (IM.MonoidalIntMap (Max a))
mrtFlatten :: forall (m :: * -> *) a.
(Monad m, Ord a) =>
MaxRoseTree m a -> m (MonoidalIntMap (Max a))
mrtFlatten = (forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a m. Monoid m => (Int -> a -> m) -> MonoidalIntMap a -> m
IM.foldMapWithKey (\Int
i (MaxRoseNode a
a m (MonoidalIntMap (MaxRoseNode m a))
inner) -> forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ (forall a. Int -> a -> MonoidalIntMap a
IM.singleton Int
i (forall a. a -> Max a
Max a
a) forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(Monad m, Ord a) =>
MaxRoseTree m a -> m (MonoidalIntMap (Max a))
mrtFlatten m (MonoidalIntMap (MaxRoseNode m a))
inner) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)
searchReachable
:: forall m force
. (Alternative m, Monad m, Enum force, Ord force)
=> Int
-> ((Int, force) -> m (IM.MonoidalIntMap (Max force)))
-> A.Array Int (m (IM.MonoidalIntMap (Max force)))
searchReachable :: forall (m :: * -> *) force.
(Alternative m, Monad m, Enum force, Ord force) =>
Int
-> ((Int, force) -> m (MonoidalIntMap (Max force)))
-> Array Int (m (MonoidalIntMap (Max force)))
searchReachable Int
maxIdx (Int, force) -> m (MonoidalIntMap (Max force))
lookupEdges = forall (m :: * -> *) a.
(Monad m, Ord a) =>
MaxRoseTree m a -> m (MonoidalIntMap (Max a))
mrtFlatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => [a] -> a
unsafeHead forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array Int [MaxRoseTree m force]
mem
where
mem :: A.Array Int [MaxRoseTree m force]
mem :: Array Int [MaxRoseTree m force]
mem = forall i e. Ix i => (i, i) -> [e] -> Array i e
A.listArray (Int
0, Int
maxIdx)
[ [(Int, force) -> MaxRoseTree m force -> MaxRoseTree m force
cutLoops forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (Int -> a -> b) -> MonoidalIntMap a -> MonoidalIntMap b
IM.mapWithKey Int -> Max force -> MaxRoseNode m force
memoizedNode) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, force) -> m (MonoidalIntMap (Max force))
lookupEdges forall a b. (a -> b) -> a -> b
$ (Int
i, force
f) | force
f <- [forall a. Enum a => Int -> a
toEnum Int
0..]]
| Int
i <- [Int
0..Int
maxIdx]
]
memoizedNode :: Int -> Max force -> MaxRoseNode m force
memoizedNode :: Int -> Max force -> MaxRoseNode m force
memoizedNode Int
i (Max force
force) = forall (m :: * -> *) a. a -> MaxRoseTree m a -> MaxRoseNode m a
MaxRoseNode force
force forall a b. (a -> b) -> a -> b
$ Array Int [MaxRoseTree m force]
mem forall i e. Ix i => Array i e -> i -> e
A.! Int
i forall a. [a] -> Int -> a
!! forall a. Enum a => a -> Int
fromEnum force
force
cutLoops :: (Int, force) -> MaxRoseTree m force -> MaxRoseTree m force
cutLoops :: (Int, force) -> MaxRoseTree m force -> MaxRoseTree m force
cutLoops (Int
i, force
force) = MaxRoseTree m force -> MaxRoseTree m force
go
where
go :: MaxRoseTree m force -> MaxRoseTree m force
go = forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Applicative t =>
(Int -> a -> t b) -> MonoidalIntMap a -> t (MonoidalIntMap b)
IM.traverseWithKey forall a b. (a -> b) -> a -> b
$ \Int
i' (MaxRoseNode force
force' MaxRoseTree m force
inner) ->
forall (m :: * -> *) a. a -> MaxRoseTree m a -> MaxRoseNode m a
MaxRoseNode force
force' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Int
i forall a. Eq a => a -> a -> Bool
== Int
i' then forall (f :: * -> *). Alternative f => Bool -> f ()
guard (force
force forall a. Ord a => a -> a -> Bool
>= force
force') forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. MonoidalIntMap a
IM.empty else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MaxRoseTree m force -> MaxRoseTree m force
go MaxRoseTree m force
inner
data RecursiveGroupItem e = EagerBinding Ann e | LazyDefinition e | LazyBinding Ann
deriving forall a b. a -> RecursiveGroupItem b -> RecursiveGroupItem a
forall a b.
(a -> b) -> RecursiveGroupItem a -> RecursiveGroupItem b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RecursiveGroupItem b -> RecursiveGroupItem a
$c<$ :: forall a b. a -> RecursiveGroupItem b -> RecursiveGroupItem a
fmap :: forall a b.
(a -> b) -> RecursiveGroupItem a -> RecursiveGroupItem b
$cfmap :: forall a b.
(a -> b) -> RecursiveGroupItem a -> RecursiveGroupItem b
Functor
applyLazinessTransform :: ModuleName -> [((Ann, Ident), Expr Ann)] -> ([((Ann, Ident), Expr Ann)], Any)
applyLazinessTransform :: ModuleName
-> [((Ann, Ident), Expr Ann)] -> ([((Ann, Ident), Expr Ann)], Any)
applyLazinessTransform ModuleName
mn [((Ann, Ident), Expr Ann)]
rawItems = let
rawItemsByName :: M.MonoidalMap Ident (Ann, Expr Ann)
rawItemsByName :: MonoidalMap Ident (Ann, Expr Ann)
rawItemsByName = forall k a. Ord k => [(k, a)] -> MonoidalMap k a
M.fromList forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((Ann, Ident), Expr Ann)]
rawItems
maxIdx :: Int
maxIdx = forall k a. MonoidalMap k a -> Int
M.size MonoidalMap Ident (Ann, Expr Ann)
rawItemsByName forall a. Num a => a -> a -> a
- Int
1
rawItemsByIndex :: A.Array Int (Ann, Expr Ann)
rawItemsByIndex :: Array Int (Ann, Expr Ann)
rawItemsByIndex = forall i e. Ix i => (i, i) -> [e] -> Array i e
A.listArray (Int
0, Int
maxIdx) forall a b. (a -> b) -> a -> b
$ forall k a. MonoidalMap k a -> [a]
M.elems MonoidalMap Ident (Ann, Expr Ann)
rawItemsByName
names :: S.Set Ident
names :: Set Ident
names = forall k a. MonoidalMap k a -> Set k
M.keysSet MonoidalMap Ident (Ann, Expr Ann)
rawItemsByName
findReferences :: Expr Ann -> IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int)))
findReferences :: Expr Ann -> MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int)))
findReferences = (forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Applicative f =>
(Int -> Maybe Int -> Ann -> Qualified Ident -> f (Expr Ann))
-> Expr Ann -> f (Expr Ann)
onVarsWithDelayAndForce forall a b. (a -> b) -> a -> b
$ \Int
delay Maybe Int
force Ann
_ -> \case
Qualified QualifiedBy
qb Ident
ident | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== ModuleName
mn) (QualifiedBy -> Maybe ModuleName
toMaybeModuleName QualifiedBy
qb), Just Int
i <- Ident
ident forall a. Ord a => a -> Set a -> Maybe Int
`S.lookupIndex` Set Ident
names
-> forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> a -> MonoidalIntMap a
IM.singleton Int
delay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> a -> MonoidalIntMap a
IM.singleton Int
i forall a b. (a -> b) -> a -> b
$ Maybe Int -> Ap Maybe (Max Int)
coerceForce Maybe Int
force
Qualified Ident
_ -> forall {k} a (b :: k). a -> Const a b
Const forall a. MonoidalIntMap a
IM.empty
refsByIndex :: A.Array Int (IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int))))
refsByIndex :: Array Int (MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int))))
refsByIndex = Expr Ann -> MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int)))
findReferences forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array Int (Ann, Expr Ann)
rawItemsByIndex
reachablesByIndex :: A.Array Int (Maybe (IM.MonoidalIntMap (Max Int)))
reachablesByIndex :: Array Int (Maybe (MonoidalIntMap (Max Int)))
reachablesByIndex = forall (m :: * -> *) force.
(Alternative m, Monad m, Enum force, Ord force) =>
Int
-> ((Int, force) -> m (MonoidalIntMap (Max force)))
-> Array Int (m (MonoidalIntMap (Max force)))
searchReachable Int
maxIdx forall a b. (a -> b) -> a -> b
$ \(Int
i, Int
force) ->
forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a m. Monoid m => (Int -> a -> m) -> MonoidalIntMap a -> m
IM.foldMapWithKey (forall a. Int -> MonoidalIntMap a -> MonoidalIntMap a
dropKeysAbove Int
force forall a b. (a -> b) -> a -> b
$ Array Int (MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int))))
refsByIndex forall i e. Ix i => Array i e -> i -> e
A.! Int
i) forall a b. (a -> b) -> a -> b
$ \Int
delay ->
forall a m. Monoid m => (Int -> a -> m) -> MonoidalIntMap a -> m
IM.foldMapWithKey forall a b. (a -> b) -> a -> b
$ \Int
i' Ap Maybe (Max Int)
force' ->
forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> MonoidalIntMap a
IM.singleton Int
i' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Max a
Max forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
force forall a. Num a => a -> a -> a
- Int
delay forall a. Num a => a -> a -> a
+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ap Maybe (Max Int) -> Maybe Int
uncoerceForce Ap Maybe (Max Int)
force'
reverseReachablesFor :: Int -> IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int)))
reverseReachablesFor :: Int -> MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int)))
reverseReachablesFor Int
i = case Array Int (Maybe (MonoidalIntMap (Max Int)))
reachablesByIndex forall i e. Ix i => Array i e -> i -> e
A.! Int
i of
Maybe (MonoidalIntMap (Max Int))
Nothing -> forall a. [(Int, a)] -> MonoidalIntMap a
IM.fromAscList forall a b. (a -> b) -> a -> b
$ (, forall a. Int -> a -> MonoidalIntMap a
IM.singleton Int
i forall a b. (a -> b) -> a -> b
$ forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap forall a. Maybe a
Nothing) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0..Int
maxIdx]
Just MonoidalIntMap (Max Int)
im -> forall a. Int -> a -> MonoidalIntMap a
IM.singleton Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MonoidalIntMap (Max Int)
im
sccs :: [SCC
(MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int))),
(Ident, (Ann, Expr Ann)))]
sccs = forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp forall a b. (a -> b) -> a -> b
$ do
(Int
i, Maybe (MonoidalIntMap (Max Int))
mbReachable) <- forall i e. Ix i => Array i e -> [(i, e)]
A.assocs Array Int (Maybe (MonoidalIntMap (Max Int)))
reachablesByIndex
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int -> MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int)))
reverseReachablesFor Int
i, (forall a. Int -> Set a -> a
S.elemAt Int
i Set Ident
names, Array Int (Ann, Expr Ann)
rawItemsByIndex forall i e. Ix i => Array i e -> i -> e
A.! Int
i)), Int
i, forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Int
0..Int
maxIdx] (IntSet -> [Int]
IS.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MonoidalIntMap a -> IntSet
IM.keysSet) Maybe (MonoidalIntMap (Max Int))
mbReachable)
(MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int)))
replacements, [(Ident, RecursiveGroupItem (Expr Ann))]
items) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [SCC
(MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int))),
(Ident, (Ann, Expr Ann)))]
sccs forall a b. (a -> b) -> a -> b
$ \case
AcyclicSCC (MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int)))
_, (Ident
ident, (Ann
a, Expr Ann
e))) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Ident
ident, forall e. Ann -> e -> RecursiveGroupItem e
EagerBinding Ann
a Expr Ann
e)]
CyclicSCC [(MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int))),
(Ident, (Ann, Expr Ann)))]
vertices -> (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a, b) -> a
fst [(MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int))),
(Ident, (Ann, Expr Ann)))]
vertices, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall e. e -> RecursiveGroupItem e
LazyDefinition 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 a b. (a, b) -> b
snd) [(MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int))),
(Ident, (Ann, Expr Ann)))]
vertices forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall e. Ann -> RecursiveGroupItem e
LazyBinding 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 a b. (a, b) -> b
snd) [(MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int))),
(Ident, (Ann, Expr Ann)))]
vertices)
replacementsByName :: M.MonoidalMap Ident (M.MonoidalMap Ident (Ap Maybe (Max Int)))
replacementsByName :: MonoidalMap Ident (MonoidalMap Ident (Ap Maybe (Max Int)))
replacementsByName = forall k a. Eq k => [(k, a)] -> MonoidalMap k a
M.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Int -> Set a -> a
S.elemAt Set Ident
names) (forall k a. Eq k => [(k, a)] -> MonoidalMap k a
M.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Int -> Set a -> a
S.elemAt Set Ident
names)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MonoidalIntMap a -> [(Int, a)]
IM.toAscList)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MonoidalIntMap a -> [(Int, a)]
IM.toAscList forall a b. (a -> b) -> a -> b
$ MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int)))
replacements
replaceReferencesWithForceCall :: (Ident, RecursiveGroupItem (Expr Ann)) -> (Ident, RecursiveGroupItem (Expr Ann))
replaceReferencesWithForceCall :: (Ident, RecursiveGroupItem (Expr Ann))
-> (Ident, RecursiveGroupItem (Expr Ann))
replaceReferencesWithForceCall pair :: (Ident, RecursiveGroupItem (Expr Ann))
pair@(Ident
ident, RecursiveGroupItem (Expr Ann)
item) = case Ident
ident forall k a. Ord k => k -> MonoidalMap k a -> Maybe a
`M.lookup` MonoidalMap Ident (MonoidalMap Ident (Ap Maybe (Max Int)))
replacementsByName of
Maybe (MonoidalMap Ident (Ap Maybe (Max Int)))
Nothing -> (Ident, RecursiveGroupItem (Expr Ann))
pair
Just MonoidalMap Ident (Ap Maybe (Max Int))
m -> let
rewriteExpr :: Expr Ann -> Expr Ann
rewriteExpr = (forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Applicative f =>
(Int -> Maybe Int -> Ann -> Qualified Ident -> f (Expr Ann))
-> Expr Ann -> f (Expr Ann)
onVarsWithDelayAndForce forall a b. (a -> b) -> a -> b
$ \Int
delay Maybe Int
_ Ann
ann -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
Qualified QualifiedBy
qb Ident
ident' | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== ModuleName
mn) (QualifiedBy -> Maybe ModuleName
toMaybeModuleName QualifiedBy
qb), forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Ord a => a -> a -> Bool
>= forall a. a -> Max a
Max Int
delay) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp) forall a b. (a -> b) -> a -> b
$ Ident
ident' forall k a. Ord k => k -> MonoidalMap k a -> Maybe a
`M.lookup` MonoidalMap Ident (Ap Maybe (Max Int))
m
-> Ann -> Ident -> Expr Ann
makeForceCall Ann
ann Ident
ident'
Qualified Ident
q -> forall a. a -> Qualified Ident -> Expr a
Var Ann
ann Qualified Ident
q
in (Ident
ident, Expr Ann -> Expr Ann
rewriteExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecursiveGroupItem (Expr Ann)
item)
in (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Ident -> RecursiveGroupItem (Expr Ann) -> ((Ann, Ident), Expr Ann)
fromRGI forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident, RecursiveGroupItem (Expr Ann))
-> (Ident, RecursiveGroupItem (Expr Ann))
replaceReferencesWithForceCall forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Ident, RecursiveGroupItem (Expr Ann))]
items, Bool -> Any
Any forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. MonoidalIntMap a -> Bool
IM.null MonoidalIntMap (MonoidalIntMap (Ap Maybe (Max Int)))
replacements)
where
nullAnn :: Ann
nullAnn = SourceSpan -> Ann
ssAnn SourceSpan
nullSourceSpan
runtimeLazy :: Expr Ann
runtimeLazy = forall a. a -> Qualified Ident -> Expr a
Var Ann
nullAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos forall a b. (a -> b) -> a -> b
$ InternalIdentData -> Ident
InternalIdent InternalIdentData
RuntimeLazyFactory
runFn3 :: Expr Ann
runFn3 = forall a. a -> Qualified Ident -> Expr a
Var Ann
nullAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.M_Data_Function_Uncurried) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Ident
Ident forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, IsString a) => a
C.S_runFn forall a. Semigroup a => a -> a -> a
<> Text
"3"
strLit :: Text -> Expr Ann
strLit = forall a. a -> Literal (Expr a) -> Expr a
Literal Ann
nullAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PSString -> Literal a
StringLiteral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PSString
mkString
lazifyIdent :: Ident -> Ident
lazifyIdent = \case
Ident Text
txt -> InternalIdentData -> Ident
InternalIdent forall a b. (a -> b) -> a -> b
$ Text -> InternalIdentData
Lazy Text
txt
Ident
_ -> forall a. HasCallStack => String -> a
internalError String
"Unexpected argument to lazifyIdent"
makeForceCall :: Ann -> Ident -> Expr Ann
makeForceCall :: Ann -> Ident -> Expr Ann
makeForceCall (SourceSpan
ss, [Comment]
_, Maybe SourceType
_, Maybe Meta
_) Ident
ident
= forall a. a -> Expr a -> Expr a -> Expr a
App Ann
nullAnn (forall a. a -> Qualified Ident -> Expr a
Var Ann
nullAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos forall a b. (a -> b) -> a -> b
$ Ident -> Ident
lazifyIdent Ident
ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Literal (Expr a) -> Expr a
Literal Ann
nullAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Either Integer Double -> Literal a
NumericLiteral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
toInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Int
sourcePosLine
forall a b. (a -> b) -> a -> b
$ SourceSpan -> SourcePos
spanStart SourceSpan
ss
fromRGI :: Ident -> RecursiveGroupItem (Expr Ann) -> ((Ann, Ident), Expr Ann)
fromRGI :: Ident -> RecursiveGroupItem (Expr Ann) -> ((Ann, Ident), Expr Ann)
fromRGI Ident
i = \case
EagerBinding Ann
a Expr Ann
e -> ((Ann
a, Ident
i), Expr Ann
e)
LazyDefinition Expr Ann
e -> ((Ann
nullAnn, Ident -> Ident
lazifyIdent Ident
i), forall a. (a -> a -> a) -> [a] -> a
foldl1' (forall a. a -> Expr a -> Expr a -> Expr a
App Ann
nullAnn) [Expr Ann
runFn3, Expr Ann
runtimeLazy, Text -> Expr Ann
strLit forall a b. (a -> b) -> a -> b
$ Ident -> Text
runIdent Ident
i, Text -> Expr Ann
strLit forall a b. (a -> b) -> a -> b
$ ModuleName -> Text
runModuleName ModuleName
mn, forall a. a -> Ident -> Expr a -> Expr a
Abs Ann
nullAnn Ident
UnusedIdent Expr Ann
e])
LazyBinding Ann
a -> ((Ann
a, Ident
i), Ann -> Ident -> Expr Ann
makeForceCall Ann
a Ident
i)
dropKeysAbove :: Int -> IM.MonoidalIntMap a -> IM.MonoidalIntMap a
dropKeysAbove :: forall a. Int -> MonoidalIntMap a -> MonoidalIntMap a
dropKeysAbove Int
n = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Int -> MonoidalIntMap a -> (MonoidalIntMap a, MonoidalIntMap a)
IM.split (Int
n forall a. Num a => a -> a -> a
+ Int
1)
coerceForce :: Maybe Int -> Ap Maybe (Max Int)
coerceForce :: Maybe Int -> Ap Maybe (Max Int)
coerceForce = coerce :: forall a b. Coercible a b => a -> b
coerce
uncoerceForce :: Ap Maybe (Max Int) -> Maybe Int
uncoerceForce :: Ap Maybe (Max Int) -> Maybe Int
uncoerceForce = coerce :: forall a b. Coercible a b => a -> b
coerce