{-# OPTIONS_GHC -fno-hpc #-}
{-# LANGUAGE AllowAmbiguousTypes,
ImplicitParams,
MagicHash,
MultiParamTypeClasses,
UndecidableInstances #-}
module Parsley.Internal.Frontend.Compiler (compile) where
import Prelude hiding (pred)
import Data.Dependent.Map (DMap)
import Data.Hashable (Hashable, hashWithSalt, hash)
import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Kind (Type)
import Data.Set (Set)
import Control.Arrow (first, second)
import Control.Monad (void, when, guard)
import Control.Monad.Reader (ReaderT, runReaderT, local, ask, MonadReader)
import GHC.Exts (Int(..), unsafeCoerce#)
import GHC.Prim (StableName#)
import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)
import Numeric (showHex)
import Parsley.Internal.Core.CombinatorAST (Combinator(..), ScopeRegister(..), Reg(..), Parser(..), traverseCombinator)
import Parsley.Internal.Core.Identifiers (IMVar, MVar(..), IΣVar, ΣVar(..), SomeΣVar)
import Parsley.Internal.Common.Fresh (HFreshT, newVar, runFreshT)
import Parsley.Internal.Common.Indexed (Fix(In), cata, cata', IFunctor(imap), (:+:)(..), (\/), Const1(..))
import Parsley.Internal.Common.State (State, get, gets, runState, execState, modify', MonadState)
import Parsley.Internal.Frontend.Optimiser (optimise)
import Parsley.Internal.Frontend.Analysis (analyse, emptyFlags, dependencyAnalysis, inliner)
import Parsley.Internal.Trace (Trace(trace))
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Dependent.Map as DMap ((!), empty, insert, mapWithKey, size)
import qualified Data.HashMap.Strict as HashMap (member, lookup, insert, empty, insertWith, (!), filter)
import qualified Data.HashSet as HashSet (member, insert, empty)
import qualified Data.Map as Map ((!))
import qualified Data.Set as Set (empty)
import qualified Parsley.Internal.Opt as Opt
{-# INLINEABLE compile #-}
compile :: forall compiled a. (Trace, ?flags :: Opt.Flags)
=> Parser a
-> (forall x. Maybe (MVar x) -> Fix Combinator x -> Set SomeΣVar -> IMVar -> compiled x)
-> (compiled a, DMap MVar compiled)
compile :: forall (compiled :: Type -> Type) a.
(Trace, ?flags::Flags) =>
Parser a
-> (forall x.
Maybe (MVar x)
-> Fix Combinator x -> Set SomeΣVar -> IMVar -> compiled x)
-> (compiled a, DMap MVar compiled)
compile (Parser Fix (Combinator :+: ScopeRegister) a
p) forall x.
Maybe (MVar x)
-> Fix Combinator x -> Set SomeΣVar -> IMVar -> compiled x
codeGen = forall a. Trace => String -> a -> a
trace (String
"COMPILING NEW PARSER WITH " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type). DMap k2 f -> Int
DMap.size DMap MVar (Fix Combinator)
μs') forall a. [a] -> [a] -> [a]
++ String
" LET BINDINGS") (forall x. Maybe (MVar x) -> Fix Combinator x -> compiled x
codeGen' forall a. Maybe a
Nothing Fix Combinator a
p', forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type) (g :: k1 -> Type).
(forall (v :: k1). k2 v -> f v -> g v) -> DMap k2 f -> DMap k2 g
DMap.mapWithKey (forall x. Maybe (MVar x) -> Fix Combinator x -> compiled x
codeGen' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) DMap MVar (Fix Combinator)
μs')
where
(Fix Combinator a
p', DMap MVar (Fix Combinator)
μs, IMVar
maxV) = forall a.
(?flags::Flags) =>
Fix (Combinator :+: ScopeRegister) a
-> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
preprocess Fix (Combinator :+: ScopeRegister) a
p
(DMap MVar (Fix Combinator)
μs', Map IMVar (Set SomeΣVar)
frs) = forall a.
Fix Combinator a
-> DMap MVar (Fix Combinator)
-> (DMap MVar (Fix Combinator), Map IMVar (Set SomeΣVar))
dependencyAnalysis Fix Combinator a
p' DMap MVar (Fix Combinator)
μs
freeRegs :: Maybe (MVar x) -> Set SomeΣVar
freeRegs :: forall x. Maybe (MVar x) -> Set SomeΣVar
freeRegs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Set a
Set.empty (\(MVar IMVar
v) -> Map IMVar (Set SomeΣVar)
frs forall k a. Ord k => Map k a -> k -> a
Map.! IMVar
v)
codeGen' :: Maybe (MVar x) -> Fix Combinator x -> compiled x
codeGen' :: forall x. Maybe (MVar x) -> Fix Combinator x -> compiled x
codeGen' Maybe (MVar x)
letBound Fix Combinator x
p = forall x.
Maybe (MVar x)
-> Fix Combinator x -> Set SomeΣVar -> IMVar -> compiled x
codeGen Maybe (MVar x)
letBound (forall a. AnalysisFlags -> Fix Combinator a -> Fix Combinator a
analyse AnalysisFlags
emptyFlags Fix Combinator x
p) (forall x. Maybe (MVar x) -> Set SomeΣVar
freeRegs Maybe (MVar x)
letBound) (IMVar
maxV forall a. Num a => a -> a -> a
+ IMVar
1)
preprocess :: (?flags :: Opt.Flags) => Fix (Combinator :+: ScopeRegister) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
preprocess :: forall a.
(?flags::Flags) =>
Fix (Combinator :+: ScopeRegister) a
-> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
preprocess Fix (Combinator :+: ScopeRegister) a
p =
let q :: Fix (Tag ParserName Combinator) a
q = forall a.
Fix (Combinator :+: ScopeRegister) a
-> Fix (Tag ParserName Combinator) a
tagParser Fix (Combinator :+: ScopeRegister) a
p
(HashMap ParserName Int
lets, HashSet ParserName
recs) = forall a.
Fix (Tag ParserName Combinator) a
-> (HashMap ParserName Int, HashSet ParserName)
findLets Fix (Tag ParserName Combinator) a
q
(Fix Combinator a
p', DMap MVar (Fix Combinator)
μs, IMVar
maxV) = forall a.
(?flags::Flags) =>
HashMap ParserName Int
-> HashSet ParserName
-> Fix (Tag ParserName Combinator) a
-> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
letInsertion HashMap ParserName Int
lets HashSet ParserName
recs Fix (Tag ParserName Combinator) a
q
in (Fix Combinator a
p', DMap MVar (Fix Combinator)
μs, IMVar
maxV)
data ParserName = forall a. ParserName (StableName# (Fix (Combinator :+: ScopeRegister) a))
data Tag t f (k :: Type -> Type) a = Tag {forall {k} t (f :: (Type -> Type) -> k -> Type) (k :: Type -> Type)
(a :: k).
Tag t f k a -> t
tag :: t, forall {k} t (f :: (Type -> Type) -> k -> Type) (k :: Type -> Type)
(a :: k).
Tag t f k a -> f k a
tagged :: f k a}
tagParser :: Fix (Combinator :+: ScopeRegister) a -> Fix (Tag ParserName Combinator) a
tagParser :: forall a.
Fix (Combinator :+: ScopeRegister) a
-> Fix (Tag ParserName Combinator) a
tagParser Fix (Combinator :+: ScopeRegister) a
p = forall (f :: (Type -> Type) -> Type -> Type) (a :: Type -> Type) i.
IFunctor f =>
(forall j. Fix f j -> f a j -> a j) -> Fix f i -> a i
cata' forall {a} {a}.
Fix (Combinator :+: ScopeRegister) a
-> (:+:)
Combinator ScopeRegister (Fix (Tag ParserName Combinator)) a
-> Fix (Tag ParserName Combinator) a
tagAlg Fix (Combinator :+: ScopeRegister) a
p
where
tagAlg :: Fix (Combinator :+: ScopeRegister) a
-> (:+:)
Combinator ScopeRegister (Fix (Tag ParserName Combinator)) a
-> Fix (Tag ParserName Combinator) a
tagAlg Fix (Combinator :+: ScopeRegister) a
p = forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} t (f :: (Type -> Type) -> k -> Type) (k :: Type -> Type)
(a :: k).
t -> f k a -> Tag t f k a
Tag (forall a. Fix (Combinator :+: ScopeRegister) a -> ParserName
makeParserName Fix (Combinator :+: ScopeRegister) a
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> a
id forall {k1} {k2} (f :: k1 -> k2 -> Type) (a :: k1) (i :: k2) b
(g :: k1 -> k2 -> Type).
(f a i -> b) -> (g a i -> b) -> (:+:) f g a i -> b
\/ forall {k :: Type -> Type} {a}. ScopeRegister k a -> Combinator k a
descope)
descope :: ScopeRegister k a -> Combinator k a
descope (ScopeRegister k a1
p forall r. Reg r a1 -> k a
f) = forall a x. IORef IΣVar -> (forall r. Reg r a -> x) -> x
freshReg IORef IΣVar
regMaker (\reg :: Reg r a1
reg@(Reg ΣVar a1
σ) -> forall a1 (k :: Type -> Type) a.
ΣVar a1 -> k a1 -> k a -> Combinator k a
MakeRegister ΣVar a1
σ k a1
p (forall r. Reg r a1 -> k a
f Reg r a1
reg))
regMaker :: IORef IΣVar
regMaker :: IORef IΣVar
regMaker = forall a. a -> IORef IΣVar
newRegMaker Fix (Combinator :+: ScopeRegister) a
p
data LetFinderState = LetFinderState { LetFinderState -> HashMap ParserName Int
preds :: HashMap ParserName Int
, LetFinderState -> HashSet ParserName
recs :: HashSet ParserName }
type LetFinderCtx = HashSet ParserName
newtype LetFinder a = LetFinder { forall {k} (a :: k).
LetFinder a
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
doLetFinder :: ReaderT LetFinderCtx (State LetFinderState) () }
findLets :: Fix (Tag ParserName Combinator) a -> (HashMap ParserName Int, HashSet ParserName)
findLets :: forall a.
Fix (Tag ParserName Combinator) a
-> (HashMap ParserName Int, HashSet ParserName)
findLets Fix (Tag ParserName Combinator) a
p = (HashMap ParserName Int
lets, HashSet ParserName
recs)
where
state :: LetFinderState
state = HashMap ParserName Int -> HashSet ParserName -> LetFinderState
LetFinderState forall k v. HashMap k v
HashMap.empty forall a. HashSet a
HashSet.empty
ctx :: HashSet a
ctx = forall a. HashSet a
HashSet.empty
LetFinderState HashMap ParserName Int
preds HashSet ParserName
recs = forall s a. State s a -> s -> s
execState (forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (forall {k} (a :: k).
LetFinder a
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
doLetFinder (forall (f :: (Type -> Type) -> Type -> Type) (a :: Type -> Type) i.
IFunctor f =>
(forall j. f a j -> a j) -> Fix f i -> a i
cata forall a. Tag ParserName Combinator LetFinder a -> LetFinder a
findLetsAlg Fix (Tag ParserName Combinator) a
p)) forall a. HashSet a
ctx) LetFinderState
state
lets :: HashMap ParserName Int
lets = forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter (forall a. Ord a => a -> a -> Bool
> Int
1) HashMap ParserName Int
preds
findLetsAlg :: Tag ParserName Combinator LetFinder a -> LetFinder a
findLetsAlg :: forall a. Tag ParserName Combinator LetFinder a -> LetFinder a
findLetsAlg Tag ParserName Combinator LetFinder a
p = forall {k} (a :: k).
ReaderT (HashSet ParserName) (State LetFinderState) ()
-> LetFinder a
LetFinder forall a b. (a -> b) -> a -> b
$ do
let name :: ParserName
name = forall {k} t (f :: (Type -> Type) -> k -> Type) (k :: Type -> Type)
(a :: k).
Tag t f k a -> t
tag Tag ParserName Combinator LetFinder a
p
forall (m :: Type -> Type).
MonadState LetFinderState m =>
ParserName -> m ()
addPred ParserName
name
forall (m :: Type -> Type) a.
MonadReader (HashSet ParserName) m =>
ParserName -> m a -> m a -> m a
ifSeen ParserName
name
(do forall (m :: Type -> Type).
MonadState LetFinderState m =>
ParserName -> m ()
addRec ParserName
name)
(forall (m :: Type -> Type).
MonadState LetFinderState m =>
ParserName -> m () -> m ()
ifNotProcessedBefore ParserName
name
(forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (forall (m :: Type -> Type) b.
MonadReader (HashSet ParserName) m =>
ParserName -> m b -> m b
addName ParserName
name (forall (m :: Type -> Type) (f :: Type -> Type) (k :: Type -> Type)
a.
Applicative m =>
(forall a1. f a1 -> m (k a1))
-> Combinator f a -> m (Combinator k a)
traverseCombinator (forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} a (k1 :: k). a -> Const1 a k1
Const1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k).
LetFinder a
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
doLetFinder) (forall {k} t (f :: (Type -> Type) -> k -> Type) (k :: Type -> Type)
(a :: k).
Tag t f k a -> f k a
tagged Tag ParserName Combinator LetFinder a
p)))))
newtype LetInserter a =
LetInserter {
forall a.
LetInserter a
-> HFreshT
IMVar
(State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
(Fix Combinator a)
doLetInserter :: HFreshT IMVar
(State ( HashMap ParserName IMVar
, DMap MVar (Fix Combinator)))
(Fix Combinator a)
}
letInsertion :: (?flags :: Opt.Flags) => HashMap ParserName Int -> HashSet ParserName -> Fix (Tag ParserName Combinator) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
letInsertion :: forall a.
(?flags::Flags) =>
HashMap ParserName Int
-> HashSet ParserName
-> Fix (Tag ParserName Combinator) a
-> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
letInsertion HashMap ParserName Int
lets HashSet ParserName
recs Fix (Tag ParserName Combinator) a
p = (Fix Combinator a
p', DMap MVar (Fix Combinator)
μs, IMVar
μMax)
where
m :: LetInserter a
m = forall (f :: (Type -> Type) -> Type -> Type) (a :: Type -> Type) i.
IFunctor f =>
(forall j. f a j -> a j) -> Fix f i -> a i
cata forall a. Tag ParserName Combinator LetInserter a -> LetInserter a
alg Fix (Tag ParserName Combinator) a
p
((Fix Combinator a
p', IMVar
μMax), (HashMap ParserName IMVar
_, DMap MVar (Fix Combinator)
μs)) = forall s a. State s a -> s -> (a, s)
runState (forall x (n :: Type -> Type) (m :: Type -> Type) a.
RunFreshT x n m =>
m a -> x -> n (a, x)
runFreshT (forall a.
LetInserter a
-> HFreshT
IMVar
(State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
(Fix Combinator a)
doLetInserter LetInserter a
m) IMVar
0) (forall k v. HashMap k v
HashMap.empty, forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type). DMap k2 f
DMap.empty)
alg :: Tag ParserName Combinator LetInserter a -> LetInserter a
alg :: forall a. Tag ParserName Combinator LetInserter a -> LetInserter a
alg Tag ParserName Combinator LetInserter a
p = forall a.
HFreshT
IMVar
(State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
(Fix Combinator a)
-> LetInserter a
LetInserter forall a b. (a -> b) -> a -> b
$ do
let name :: ParserName
name = forall {k} t (f :: (Type -> Type) -> k -> Type) (k :: Type -> Type)
(a :: k).
Tag t f k a -> t
tag Tag ParserName Combinator LetInserter a
p
let q :: Combinator LetInserter a
q = forall {k} t (f :: (Type -> Type) -> k -> Type) (k :: Type -> Type)
(a :: k).
Tag t f k a -> f k a
tagged Tag ParserName Combinator LetInserter a
p
(HashMap ParserName IMVar
vs, DMap MVar (Fix Combinator)
μs) <- forall s (m :: Type -> Type). MonadState s m => m s
get
let bound :: Bool
bound = forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member ParserName
name HashMap ParserName Int
lets
let recu :: Bool
recu = forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member ParserName
name HashSet ParserName
recs
let occs :: Maybe Int
occs = forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
recu) forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup ParserName
name HashMap ParserName Int
lets
if Bool
bound Bool -> Bool -> Bool
|| Bool
recu then case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup ParserName
name HashMap ParserName IMVar
vs of
Just IMVar
v -> let μ :: MVar a
μ = forall a. IMVar -> MVar a
MVar IMVar
v in forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a.
(?flags::Flags) =>
Maybe Int -> MVar a -> Fix Combinator a -> Fix Combinator a
inliner Maybe Int
occs MVar a
μ (DMap MVar (Fix Combinator)
μs forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
DMap k2 f -> k2 v -> f v
DMap.! MVar a
μ)
Maybe IMVar
Nothing -> do
IMVar
v <- forall x (m :: Type -> Type). MonadFresh x m => m x
newVar
let μ :: MVar a
μ = forall a. IMVar -> MVar a
MVar IMVar
v
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' (forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert ParserName
name IMVar
v))
Fix Combinator a
q' <- forall a.
LetInserter a
-> HFreshT
IMVar
(State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
(Fix Combinator a)
doLetInserter (forall a.
(?flags::Flags) =>
Combinator LetInserter a -> LetInserter a
postprocess Combinator LetInserter a
q)
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' (forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> f v -> DMap k2 f -> DMap k2 f
DMap.insert MVar a
μ Fix Combinator a
q'))
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a.
(?flags::Flags) =>
Maybe Int -> MVar a -> Fix Combinator a -> Fix Combinator a
inliner Maybe Int
occs MVar a
μ Fix Combinator a
q'
else do forall a.
LetInserter a
-> HFreshT
IMVar
(State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
(Fix Combinator a)
doLetInserter (forall a.
(?flags::Flags) =>
Combinator LetInserter a -> LetInserter a
postprocess Combinator LetInserter a
q)
postprocess :: (?flags :: Opt.Flags) => Combinator LetInserter a -> LetInserter a
postprocess :: forall a.
(?flags::Flags) =>
Combinator LetInserter a -> LetInserter a
postprocess = forall a.
HFreshT
IMVar
(State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
(Fix Combinator a)
-> LetInserter a
LetInserter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a.
(?flags::Flags) =>
Combinator (Fix Combinator) a -> Fix Combinator a
optimise forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: Type -> Type) (f :: Type -> Type) (k :: Type -> Type)
a.
Applicative m =>
(forall a1. f a1 -> m (k a1))
-> Combinator f a -> m (Combinator k a)
traverseCombinator forall a.
LetInserter a
-> HFreshT
IMVar
(State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
(Fix Combinator a)
doLetInserter
modifyPreds :: MonadState LetFinderState m => (HashMap ParserName Int -> HashMap ParserName Int) -> m ()
modifyPreds :: forall (m :: Type -> Type).
MonadState LetFinderState m =>
(HashMap ParserName Int -> HashMap ParserName Int) -> m ()
modifyPreds HashMap ParserName Int -> HashMap ParserName Int
f = forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' (\LetFinderState
st -> LetFinderState
st {preds :: HashMap ParserName Int
preds = HashMap ParserName Int -> HashMap ParserName Int
f (LetFinderState -> HashMap ParserName Int
preds LetFinderState
st)})
modifyRecs :: MonadState LetFinderState m => (HashSet ParserName -> HashSet ParserName) -> m ()
modifyRecs :: forall (m :: Type -> Type).
MonadState LetFinderState m =>
(HashSet ParserName -> HashSet ParserName) -> m ()
modifyRecs HashSet ParserName -> HashSet ParserName
f = forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' (\LetFinderState
st -> LetFinderState
st {recs :: HashSet ParserName
recs = HashSet ParserName -> HashSet ParserName
f (LetFinderState -> HashSet ParserName
recs LetFinderState
st)})
addPred :: MonadState LetFinderState m => ParserName -> m ()
addPred :: forall (m :: Type -> Type).
MonadState LetFinderState m =>
ParserName -> m ()
addPred ParserName
k = forall (m :: Type -> Type).
MonadState LetFinderState m =>
(HashMap ParserName Int -> HashMap ParserName Int) -> m ()
modifyPreds (forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith forall a. Num a => a -> a -> a
(+) ParserName
k Int
1)
addRec :: MonadState LetFinderState m => ParserName -> m ()
addRec :: forall (m :: Type -> Type).
MonadState LetFinderState m =>
ParserName -> m ()
addRec = forall (m :: Type -> Type).
MonadState LetFinderState m =>
(HashSet ParserName -> HashSet ParserName) -> m ()
modifyRecs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert
ifSeen :: MonadReader LetFinderCtx m => ParserName -> m a -> m a -> m a
ifSeen :: forall (m :: Type -> Type) a.
MonadReader (HashSet ParserName) m =>
ParserName -> m a -> m a -> m a
ifSeen ParserName
x m a
yes m a
no = do HashSet ParserName
seen <- forall r (m :: Type -> Type). MonadReader r m => m r
ask; if forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member ParserName
x HashSet ParserName
seen then m a
yes else m a
no
ifNotProcessedBefore :: MonadState LetFinderState m => ParserName -> m () -> m ()
ifNotProcessedBefore :: forall (m :: Type -> Type).
MonadState LetFinderState m =>
ParserName -> m () -> m ()
ifNotProcessedBefore ParserName
x m ()
m =
do Bool
oneReference <- forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets ((forall a. Eq a => a -> a -> Bool
== Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
HashMap.! ParserName
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetFinderState -> HashMap ParserName Int
preds)
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
oneReference m ()
m
addName :: MonadReader LetFinderCtx m => ParserName -> m b -> m b
addName :: forall (m :: Type -> Type) b.
MonadReader (HashSet ParserName) m =>
ParserName -> m b -> m b
addName ParserName
x = forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
local (forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert ParserName
x)
makeParserName :: Fix (Combinator :+: ScopeRegister) a -> ParserName
makeParserName :: forall a. Fix (Combinator :+: ScopeRegister) a -> ParserName
makeParserName !Fix (Combinator :+: ScopeRegister) a
p = forall a. IO a -> a
unsafePerformIO (forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(StableName StableName# (Fix (Combinator :+: ScopeRegister) a)
name) -> forall a.
StableName# (Fix (Combinator :+: ScopeRegister) a) -> ParserName
ParserName StableName# (Fix (Combinator :+: ScopeRegister) a)
name) (forall a. a -> IO (StableName a)
makeStableName Fix (Combinator :+: ScopeRegister) a
p))
{-# NOINLINE newRegMaker #-}
newRegMaker :: a -> IORef IΣVar
newRegMaker :: forall a. a -> IORef IΣVar
newRegMaker a
x = a
x seq :: forall a b. a -> b -> b
`seq` forall a. IO a -> a
unsafePerformIO (forall a. a -> IO (IORef a)
newIORef IΣVar
0)
{-# NOINLINE freshReg #-}
freshReg :: IORef IΣVar -> (forall r. Reg r a -> x) -> x
freshReg :: forall a x. IORef IΣVar -> (forall r. Reg r a -> x) -> x
freshReg IORef IΣVar
maker forall r. Reg r a -> x
scope = forall r. Reg r a -> x
scope forall a b. (a -> b) -> a -> b
$ forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
IΣVar
x <- forall a. IORef a -> IO a
readIORef IORef IΣVar
maker
forall a. IORef a -> a -> IO ()
writeIORef IORef IΣVar
maker (IΣVar
x forall a. Num a => a -> a -> a
+ IΣVar
1)
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall r a. ΣVar a -> Reg r a
Reg (forall a. IΣVar -> ΣVar a
ΣVar IΣVar
x)
instance IFunctor f => IFunctor (Tag t f) where
imap :: forall (a :: Type -> Type) (b :: Type -> Type) i.
(forall j. a j -> b j) -> Tag t f a i -> Tag t f b i
imap forall j. a j -> b j
f (Tag t
t f a i
k) = forall {k} t (f :: (Type -> Type) -> k -> Type) (k :: Type -> Type)
(a :: k).
t -> f k a -> Tag t f k a
Tag t
t (forall (f :: (Type -> Type) -> Type -> Type) (a :: Type -> Type)
(b :: Type -> Type) i.
IFunctor f =>
(forall j. a j -> b j) -> f a i -> f b i
imap forall j. a j -> b j
f f a i
k)
instance Eq ParserName where
(ParserName StableName# (Fix (Combinator :+: ScopeRegister) a)
n) == :: ParserName -> ParserName -> Bool
== (ParserName StableName# (Fix (Combinator :+: ScopeRegister) a)
m) = forall a b. StableName a -> StableName b -> Bool
eqStableName (forall a. StableName# a -> StableName a
StableName StableName# (Fix (Combinator :+: ScopeRegister) a)
n) (forall a. StableName# a -> StableName a
StableName StableName# (Fix (Combinator :+: ScopeRegister) a)
m)
instance Hashable ParserName where
hash :: ParserName -> Int
hash (ParserName StableName# (Fix (Combinator :+: ScopeRegister) a)
n) = forall a. StableName a -> Int
hashStableName (forall a. StableName# a -> StableName a
StableName StableName# (Fix (Combinator :+: ScopeRegister) a)
n)
hashWithSalt :: Int -> ParserName -> Int
hashWithSalt Int
salt (ParserName StableName# (Fix (Combinator :+: ScopeRegister) a)
n) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (forall a. StableName# a -> StableName a
StableName StableName# (Fix (Combinator :+: ScopeRegister) a)
n)
instance Show ParserName where showsPrec :: Int -> ParserName -> ShowS
showsPrec Int
_ (ParserName StableName# (Fix (Combinator :+: ScopeRegister) a)
n) = forall a. (Integral a, Show a) => a -> ShowS
showHex (Int# -> Int
I# (unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# StableName# (Fix (Combinator :+: ScopeRegister) a)
n))