{-# OPTIONS_GHC -fno-hpc #-}
{-# LANGUAGE AllowAmbiguousTypes,
             ImplicitParams,
             MagicHash,
             MultiParamTypeClasses,
             UndecidableInstances #-}
{-|
Module      : Parsley.Internal.Frontend.Compiler
Description : Compile and analyse a parser
License     : BSD-3-Clause
Maintainer  : Jamie Willis
Stability   : experimental

Exposes `compile` which is used to detect recursion, let-bindings and compile them
into another representation with a code generation function.

@since 1.0.0.0
-}
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

{-|
Given a user's parser, this will analyse it, extract bindings and then compile them with a given function
provided with the information that has been distilled about each binding. Returns all the prepared bindings
along with the top-level definition.

@since 1.0.0.0
-}
{-# INLINEABLE compile #-}
compile :: forall compiled a. (Trace, ?flags :: Opt.Flags)
        => Parser a                                                                              -- ^ The parser to compile.
        -> (forall x. Maybe (MVar x) -> Fix Combinator x -> Set SomeΣVar -> IMVar -> compiled x) -- ^ How to generate a compiled value with the distilled information.
        -> (compiled a, DMap MVar compiled)                                                      -- ^ The compiled top-level and all of the bindings.
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
-- Force evaluation of p to ensure that the stableName is correct first time
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))

-- The argument here stops GHC from floating it out, it should be provided something from the scope
{-# 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)

-- There is great evil in this world, and I'm probably responsible for half of it
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))