{-# OPTIONS_GHC -fno-hpc #-}
{-# LANGUAGE AllowAmbiguousTypes,
             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)
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 (lookup, insert, empty, insertWith, foldrWithKey, (!))
import qualified Data.HashSet        as HashSet (member, insert, empty)
import qualified Data.Map            as Map     ((!))
import qualified Data.Set            as Set     (empty)

{-|
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
        => 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 :: 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 = String
-> (compiled a, DMap MVar compiled)
-> (compiled a, DMap MVar compiled)
forall a. Trace => String -> a -> a
trace (String
"COMPILING NEW PARSER WITH " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (DMap MVar (Fix Combinator) -> Int
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type). DMap k2 f -> Int
DMap.size DMap MVar (Fix Combinator)
μs') String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" LET BINDINGS") (Maybe (MVar a) -> Fix Combinator a -> compiled a
forall x. Maybe (MVar x) -> Fix Combinator x -> compiled x
codeGen' Maybe (MVar a)
forall a. Maybe a
Nothing Fix Combinator a
p', (forall v. MVar v -> Fix Combinator v -> compiled v)
-> DMap MVar (Fix Combinator) -> DMap MVar compiled
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 (Maybe (MVar v) -> Fix Combinator v -> compiled v
forall x. Maybe (MVar x) -> Fix Combinator x -> compiled x
codeGen' (Maybe (MVar v) -> Fix Combinator v -> compiled v)
-> (MVar v -> Maybe (MVar v))
-> MVar v
-> Fix Combinator v
-> compiled v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar v -> Maybe (MVar v)
forall a. a -> Maybe a
Just) DMap MVar (Fix Combinator)
μs')
  where
    (Fix Combinator a
p', DMap MVar (Fix Combinator)
μs, IMVar
maxV) = Fix (Combinator :+: ScopeRegister) a
-> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
forall a.
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) = Fix Combinator a
-> DMap MVar (Fix Combinator)
-> (DMap MVar (Fix Combinator), Map IMVar (Set SomeΣVar))
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 :: Maybe (MVar x) -> Set SomeΣVar
freeRegs = Set SomeΣVar
-> (MVar x -> Set SomeΣVar) -> Maybe (MVar x) -> Set SomeΣVar
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set SomeΣVar
forall a. Set a
Set.empty (\(MVar IMVar
v) -> Map IMVar (Set SomeΣVar)
frs Map IMVar (Set SomeΣVar) -> IMVar -> Set SomeΣVar
forall k a. Ord k => Map k a -> k -> a
Map.! IMVar
v)

    codeGen' :: Maybe (MVar x) -> Fix Combinator x -> compiled x
    codeGen' :: Maybe (MVar x) -> Fix Combinator x -> compiled x
codeGen' Maybe (MVar x)
letBound Fix Combinator x
p = Maybe (MVar x)
-> Fix Combinator x -> Set SomeΣVar -> IMVar -> compiled x
forall x.
Maybe (MVar x)
-> Fix Combinator x -> Set SomeΣVar -> IMVar -> compiled x
codeGen Maybe (MVar x)
letBound (AnalysisFlags -> Fix Combinator x -> Fix Combinator x
forall a. AnalysisFlags -> Fix Combinator a -> Fix Combinator a
analyse AnalysisFlags
emptyFlags Fix Combinator x
p) (Maybe (MVar x) -> Set SomeΣVar
forall x. Maybe (MVar x) -> Set SomeΣVar
freeRegs Maybe (MVar x)
letBound) (IMVar
maxV IMVar -> IMVar -> IMVar
forall a. Num a => a -> a -> a
+ IMVar
1)

preprocess :: Fix (Combinator :+: ScopeRegister) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
preprocess :: 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 = Fix (Combinator :+: ScopeRegister) a
-> Fix (Tag ParserName Combinator) a
forall a.
Fix (Combinator :+: ScopeRegister) a
-> Fix (Tag ParserName Combinator) a
tagParser Fix (Combinator :+: ScopeRegister) a
p
      (HashSet ParserName
lets, HashSet ParserName
recs) = Fix (Tag ParserName Combinator) a
-> (HashSet ParserName, HashSet ParserName)
forall a.
Fix (Tag ParserName Combinator) a
-> (HashSet ParserName, HashSet ParserName)
findLets Fix (Tag ParserName Combinator) a
q
      (Fix Combinator a
p', DMap MVar (Fix Combinator)
μs, IMVar
maxV) = HashSet ParserName
-> HashSet ParserName
-> Fix (Tag ParserName Combinator) a
-> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
forall a.
HashSet ParserName
-> HashSet ParserName
-> Fix (Tag ParserName Combinator) a
-> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
letInsertion HashSet ParserName
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 {Tag t f k a -> t
tag :: t, Tag t f k a -> f k a
tagged :: f k a}

tagParser :: Fix (Combinator :+: ScopeRegister) a -> Fix (Tag ParserName Combinator) a
tagParser :: Fix (Combinator :+: ScopeRegister) a
-> Fix (Tag ParserName Combinator) a
tagParser Fix (Combinator :+: ScopeRegister) a
p = (forall j.
 Fix (Combinator :+: ScopeRegister) j
 -> (:+:)
      Combinator ScopeRegister (Fix (Tag ParserName Combinator)) j
 -> Fix (Tag ParserName Combinator) j)
-> Fix (Combinator :+: ScopeRegister) a
-> Fix (Tag ParserName Combinator) a
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 j.
Fix (Combinator :+: ScopeRegister) j
-> (:+:)
     Combinator ScopeRegister (Fix (Tag ParserName Combinator)) j
-> Fix (Tag ParserName Combinator) j
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 = Tag ParserName Combinator (Fix (Tag ParserName Combinator)) a
-> Fix (Tag ParserName Combinator) a
forall k (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In (Tag ParserName Combinator (Fix (Tag ParserName Combinator)) a
 -> Fix (Tag ParserName Combinator) a)
-> ((:+:)
      Combinator ScopeRegister (Fix (Tag ParserName Combinator)) a
    -> Tag ParserName Combinator (Fix (Tag ParserName Combinator)) a)
-> (:+:)
     Combinator ScopeRegister (Fix (Tag ParserName Combinator)) a
-> Fix (Tag ParserName Combinator) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserName
-> Combinator (Fix (Tag ParserName Combinator)) a
-> Tag ParserName Combinator (Fix (Tag ParserName Combinator)) a
forall k t (f :: (Type -> Type) -> k -> Type) (k :: Type -> Type)
       (a :: k).
t -> f k a -> Tag t f k a
Tag (Fix (Combinator :+: ScopeRegister) a -> ParserName
forall a. Fix (Combinator :+: ScopeRegister) a -> ParserName
makeParserName Fix (Combinator :+: ScopeRegister) a
p) (Combinator (Fix (Tag ParserName Combinator)) a
 -> Tag ParserName Combinator (Fix (Tag ParserName Combinator)) a)
-> ((:+:)
      Combinator ScopeRegister (Fix (Tag ParserName Combinator)) a
    -> Combinator (Fix (Tag ParserName Combinator)) a)
-> (:+:)
     Combinator ScopeRegister (Fix (Tag ParserName Combinator)) a
-> Tag ParserName Combinator (Fix (Tag ParserName Combinator)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Combinator (Fix (Tag ParserName Combinator)) a
-> Combinator (Fix (Tag ParserName Combinator)) a
forall a. a -> a
id (Combinator (Fix (Tag ParserName Combinator)) a
 -> Combinator (Fix (Tag ParserName Combinator)) a)
-> (ScopeRegister (Fix (Tag ParserName Combinator)) a
    -> Combinator (Fix (Tag ParserName Combinator)) a)
-> (:+:)
     Combinator ScopeRegister (Fix (Tag ParserName Combinator)) a
-> Combinator (Fix (Tag ParserName Combinator)) a
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
\/ ScopeRegister (Fix (Tag ParserName Combinator)) a
-> Combinator (Fix (Tag ParserName Combinator)) a
forall (k :: Type -> Type) a. ScopeRegister k a -> Combinator k a
descope)
    descope :: ScopeRegister k a -> Combinator k a
descope (ScopeRegister k a
p forall r. Reg r a -> k a
f) = IORef IΣVar
-> (forall r. Reg r a -> Combinator k a) -> Combinator k a
forall a x. IORef IΣVar -> (forall r. Reg r a -> x) -> x
freshReg IORef IΣVar
regMaker (\reg :: Reg r a
reg@(Reg ΣVar a
σ) -> ΣVar a -> k a -> k a -> Combinator k a
forall a (k :: Type -> Type) b.
ΣVar a -> k a -> k b -> Combinator k b
MakeRegister ΣVar a
σ k a
p (Reg r a -> k a
forall r. Reg r a -> k a
f Reg r a
reg))
    regMaker :: IORef IΣVar
    regMaker :: IORef IΣVar
regMaker = Fix (Combinator :+: ScopeRegister) a -> IORef IΣVar
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 { LetFinder a
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
doLetFinder :: ReaderT LetFinderCtx (State LetFinderState) () }

findLets :: Fix (Tag ParserName Combinator) a -> (HashSet ParserName, HashSet ParserName)
findLets :: Fix (Tag ParserName Combinator) a
-> (HashSet ParserName, HashSet ParserName)
findLets Fix (Tag ParserName Combinator) a
p = (HashSet ParserName
lets, HashSet ParserName
recs)
  where
    state :: LetFinderState
state = HashMap ParserName Int -> HashSet ParserName -> LetFinderState
LetFinderState HashMap ParserName Int
forall k v. HashMap k v
HashMap.empty HashSet ParserName
forall a. HashSet a
HashSet.empty
    ctx :: HashSet a
ctx = HashSet a
forall a. HashSet a
HashSet.empty
    LetFinderState HashMap ParserName Int
preds HashSet ParserName
recs = State LetFinderState () -> LetFinderState -> LetFinderState
forall s a. State s a -> s -> s
execState (ReaderT (HashSet ParserName) (State LetFinderState) ()
-> HashSet ParserName -> State LetFinderState ()
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (LetFinder a
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
forall k (a :: k).
LetFinder a
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
doLetFinder ((forall j. Tag ParserName Combinator LetFinder j -> LetFinder j)
-> Fix (Tag ParserName Combinator) a -> LetFinder a
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 j. Tag ParserName Combinator LetFinder j -> LetFinder j
findLetsAlg Fix (Tag ParserName Combinator) a
p)) HashSet ParserName
forall a. HashSet a
ctx) LetFinderState
state
    lets :: HashSet ParserName
lets = (ParserName -> Int -> HashSet ParserName -> HashSet ParserName)
-> HashSet ParserName
-> HashMap ParserName Int
-> HashSet ParserName
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey (\ParserName
k Int
n HashSet ParserName
ls -> if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then ParserName -> HashSet ParserName -> HashSet ParserName
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert ParserName
k HashSet ParserName
ls else HashSet ParserName
ls) HashSet ParserName
forall a. HashSet a
HashSet.empty HashMap ParserName Int
preds

findLetsAlg :: Tag ParserName Combinator LetFinder a -> LetFinder a
findLetsAlg :: Tag ParserName Combinator LetFinder a -> LetFinder a
findLetsAlg Tag ParserName Combinator LetFinder a
p = ReaderT (HashSet ParserName) (State LetFinderState) ()
-> LetFinder a
forall k (a :: k).
ReaderT (HashSet ParserName) (State LetFinderState) ()
-> LetFinder a
LetFinder (ReaderT (HashSet ParserName) (State LetFinderState) ()
 -> LetFinder a)
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
-> LetFinder a
forall a b. (a -> b) -> a -> b
$ do
  let name :: ParserName
name = Tag ParserName Combinator LetFinder a -> ParserName
forall t k (f :: (Type -> Type) -> k -> Type) (k :: Type -> Type)
       (a :: k).
Tag t f k a -> t
tag Tag ParserName Combinator LetFinder a
p
  ParserName
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
forall (m :: Type -> Type).
MonadState LetFinderState m =>
ParserName -> m ()
addPred ParserName
name
  ParserName
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
forall (m :: Type -> Type) a.
MonadReader (HashSet ParserName) m =>
ParserName -> m a -> m a -> m a
ifSeen ParserName
name
    (do ParserName
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
forall (m :: Type -> Type).
MonadState LetFinderState m =>
ParserName -> m ()
addRec ParserName
name)
    (ParserName
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
forall (m :: Type -> Type).
MonadState LetFinderState m =>
ParserName -> m () -> m ()
ifNotProcessedBefore ParserName
name
      (ReaderT
  (HashSet ParserName)
  (State LetFinderState)
  (Combinator (Const1 ()) a)
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (ParserName
-> ReaderT
     (HashSet ParserName)
     (State LetFinderState)
     (Combinator (Const1 ()) a)
-> ReaderT
     (HashSet ParserName)
     (State LetFinderState)
     (Combinator (Const1 ()) a)
forall (m :: Type -> Type) b.
MonadReader (HashSet ParserName) m =>
ParserName -> m b -> m b
addName ParserName
name ((forall a1.
 LetFinder a1
 -> ReaderT
      (HashSet ParserName) (State LetFinderState) (Const1 () a1))
-> Combinator LetFinder a
-> ReaderT
     (HashSet ParserName)
     (State LetFinderState)
     (Combinator (Const1 ()) a)
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 ((() -> Const1 () a1)
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
-> ReaderT
     (HashSet ParserName) (State LetFinderState) (Const1 () a1)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> Const1 () a1
forall k a (k :: k). a -> Const1 a k
Const1 (ReaderT (HashSet ParserName) (State LetFinderState) ()
 -> ReaderT
      (HashSet ParserName) (State LetFinderState) (Const1 () a1))
-> (LetFinder a1
    -> ReaderT (HashSet ParserName) (State LetFinderState) ())
-> LetFinder a1
-> ReaderT
     (HashSet ParserName) (State LetFinderState) (Const1 () a1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetFinder a1
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
forall k (a :: k).
LetFinder a
-> ReaderT (HashSet ParserName) (State LetFinderState) ()
doLetFinder) (Tag ParserName Combinator LetFinder a -> Combinator LetFinder a
forall t k (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 {
      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 :: HashSet ParserName -> HashSet ParserName -> Fix (Tag ParserName Combinator) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
letInsertion :: HashSet ParserName
-> HashSet ParserName
-> Fix (Tag ParserName Combinator) a
-> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)
letInsertion HashSet ParserName
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 j.
 Tag ParserName Combinator LetInserter j -> LetInserter j)
-> Fix (Tag ParserName Combinator) a -> LetInserter a
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 j. Tag ParserName Combinator LetInserter j -> LetInserter j
alg Fix (Tag ParserName Combinator) a
p
    ((Fix Combinator a
p', IMVar
μMax), (HashMap ParserName IMVar
_, DMap MVar (Fix Combinator)
μs)) = State
  (HashMap ParserName IMVar, DMap MVar (Fix Combinator))
  (Fix Combinator a, IMVar)
-> (HashMap ParserName IMVar, DMap MVar (Fix Combinator))
-> ((Fix Combinator a, IMVar),
    (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
forall s a. State s a -> s -> (a, s)
runState (HFreshT
  IMVar
  (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
  (Fix Combinator a)
-> IMVar
-> State
     (HashMap ParserName IMVar, DMap MVar (Fix Combinator))
     (Fix Combinator a, IMVar)
forall x (n :: Type -> Type) (m :: Type -> Type) a.
RunFreshT x n m =>
m a -> x -> n (a, x)
runFreshT (LetInserter a
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Fix Combinator a)
forall a.
LetInserter a
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Fix Combinator a)
doLetInserter LetInserter a
m) IMVar
0) (HashMap ParserName IMVar
forall k v. HashMap k v
HashMap.empty, DMap MVar (Fix Combinator)
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type). DMap k2 f
DMap.empty)
    alg :: Tag ParserName Combinator LetInserter a -> LetInserter a
    alg :: Tag ParserName Combinator LetInserter a -> LetInserter a
alg Tag ParserName Combinator LetInserter a
p = HFreshT
  IMVar
  (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
  (Fix Combinator a)
-> LetInserter a
forall a.
HFreshT
  IMVar
  (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
  (Fix Combinator a)
-> LetInserter a
LetInserter (HFreshT
   IMVar
   (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
   (Fix Combinator a)
 -> LetInserter a)
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Fix Combinator a)
-> LetInserter a
forall a b. (a -> b) -> a -> b
$ do
      let name :: ParserName
name = Tag ParserName Combinator LetInserter a -> ParserName
forall t k (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 = Tag ParserName Combinator LetInserter a -> Combinator LetInserter a
forall t k (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) <- HFreshT
  IMVar
  (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
  (HashMap ParserName IMVar, DMap MVar (Fix Combinator))
forall s (m :: Type -> Type). MonadState s m => m s
get
      let bound :: Bool
bound = ParserName -> HashSet ParserName -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member ParserName
name HashSet ParserName
lets
      let recu :: Bool
recu = ParserName -> HashSet ParserName -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member ParserName
name HashSet ParserName
recs
      if Bool
bound Bool -> Bool -> Bool
|| Bool
recu then case ParserName -> HashMap ParserName IMVar -> Maybe IMVar
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
μ = IMVar -> MVar a
forall a. IMVar -> MVar a
MVar IMVar
v in Fix Combinator a
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Fix Combinator a)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Fix Combinator a
 -> HFreshT
      IMVar
      (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
      (Fix Combinator a))
-> Fix Combinator a
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Fix Combinator a)
forall a b. (a -> b) -> a -> b
$! Bool -> MVar a -> Fix Combinator a -> Fix Combinator a
forall a. Bool -> MVar a -> Fix Combinator a -> Fix Combinator a
inliner Bool
recu MVar a
μ (DMap MVar (Fix Combinator)
μs DMap MVar (Fix Combinator) -> MVar a -> Fix Combinator a
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 <- HFreshT
  IMVar
  (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
  IMVar
forall x (m :: Type -> Type). MonadFresh x m => m x
newVar
          let μ :: MVar a
μ = IMVar -> MVar a
forall a. IMVar -> MVar a
MVar IMVar
v
          ((HashMap ParserName IMVar, DMap MVar (Fix Combinator))
 -> (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' ((HashMap ParserName IMVar -> HashMap ParserName IMVar)
-> (HashMap ParserName IMVar, DMap MVar (Fix Combinator))
-> (HashMap ParserName IMVar, DMap MVar (Fix Combinator))
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (ParserName
-> IMVar -> HashMap ParserName IMVar -> HashMap ParserName IMVar
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' <- LetInserter a
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Fix Combinator a)
forall a.
LetInserter a
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Fix Combinator a)
doLetInserter (Combinator LetInserter a -> LetInserter a
forall a. Combinator LetInserter a -> LetInserter a
postprocess Combinator LetInserter a
q)
          ((HashMap ParserName IMVar, DMap MVar (Fix Combinator))
 -> (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' ((DMap MVar (Fix Combinator) -> DMap MVar (Fix Combinator))
-> (HashMap ParserName IMVar, DMap MVar (Fix Combinator))
-> (HashMap ParserName IMVar, DMap MVar (Fix Combinator))
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (MVar a
-> Fix Combinator a
-> DMap MVar (Fix Combinator)
-> DMap MVar (Fix Combinator)
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'))
          Fix Combinator a
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Fix Combinator a)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Fix Combinator a
 -> HFreshT
      IMVar
      (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
      (Fix Combinator a))
-> Fix Combinator a
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Fix Combinator a)
forall a b. (a -> b) -> a -> b
$! Bool -> MVar a -> Fix Combinator a -> Fix Combinator a
forall a. Bool -> MVar a -> Fix Combinator a -> Fix Combinator a
inliner Bool
recu MVar a
μ Fix Combinator a
q'
      else do LetInserter a
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Fix Combinator a)
forall a.
LetInserter a
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Fix Combinator a)
doLetInserter (Combinator LetInserter a -> LetInserter a
forall a. Combinator LetInserter a -> LetInserter a
postprocess Combinator LetInserter a
q)

postprocess :: Combinator LetInserter a -> LetInserter a
postprocess :: Combinator LetInserter a -> LetInserter a
postprocess = HFreshT
  IMVar
  (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
  (Fix Combinator a)
-> LetInserter a
forall a.
HFreshT
  IMVar
  (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
  (Fix Combinator a)
-> LetInserter a
LetInserter (HFreshT
   IMVar
   (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
   (Fix Combinator a)
 -> LetInserter a)
-> (Combinator LetInserter a
    -> HFreshT
         IMVar
         (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
         (Fix Combinator a))
-> Combinator LetInserter a
-> LetInserter a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Combinator (Fix Combinator) a -> Fix Combinator a)
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Combinator (Fix Combinator) a)
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Fix Combinator a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Combinator (Fix Combinator) a -> Fix Combinator a
forall a. Combinator (Fix Combinator) a -> Fix Combinator a
optimise (HFreshT
   IMVar
   (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
   (Combinator (Fix Combinator) a)
 -> HFreshT
      IMVar
      (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
      (Fix Combinator a))
-> (Combinator LetInserter a
    -> HFreshT
         IMVar
         (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
         (Combinator (Fix Combinator) a))
-> Combinator LetInserter a
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Fix Combinator a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a.
 LetInserter a
 -> HFreshT
      IMVar
      (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
      (Fix Combinator a))
-> Combinator LetInserter a
-> HFreshT
     IMVar
     (State (HashMap ParserName IMVar, DMap MVar (Fix Combinator)))
     (Combinator (Fix Combinator) a)
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 :: (HashMap ParserName Int -> HashMap ParserName Int) -> m ()
modifyPreds HashMap ParserName Int -> HashMap ParserName Int
f = (LetFinderState -> LetFinderState) -> m ()
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 :: (HashSet ParserName -> HashSet ParserName) -> m ()
modifyRecs HashSet ParserName -> HashSet ParserName
f = (LetFinderState -> LetFinderState) -> m ()
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 :: ParserName -> m ()
addPred ParserName
k = (HashMap ParserName Int -> HashMap ParserName Int) -> m ()
forall (m :: Type -> Type).
MonadState LetFinderState m =>
(HashMap ParserName Int -> HashMap ParserName Int) -> m ()
modifyPreds ((Int -> Int -> Int)
-> ParserName
-> Int
-> HashMap ParserName Int
-> HashMap ParserName Int
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ParserName
k Int
1)

addRec :: MonadState LetFinderState m => ParserName -> m ()
addRec :: ParserName -> m ()
addRec = (HashSet ParserName -> HashSet ParserName) -> m ()
forall (m :: Type -> Type).
MonadState LetFinderState m =>
(HashSet ParserName -> HashSet ParserName) -> m ()
modifyRecs ((HashSet ParserName -> HashSet ParserName) -> m ())
-> (ParserName -> HashSet ParserName -> HashSet ParserName)
-> ParserName
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserName -> HashSet ParserName -> HashSet ParserName
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 :: ParserName -> m a -> m a -> m a
ifSeen ParserName
x m a
yes m a
no = do HashSet ParserName
seen <- m (HashSet ParserName)
forall r (m :: Type -> Type). MonadReader r m => m r
ask; if ParserName -> HashSet ParserName -> Bool
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 :: ParserName -> m () -> m ()
ifNotProcessedBefore ParserName
x m ()
m =
  do Bool
oneReference <- (LetFinderState -> Bool) -> m Bool
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> (LetFinderState -> Int) -> LetFinderState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap ParserName Int -> ParserName -> Int
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
HashMap.! ParserName
x) (HashMap ParserName Int -> Int)
-> (LetFinderState -> HashMap ParserName Int)
-> LetFinderState
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetFinderState -> HashMap ParserName Int
preds)
     Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
oneReference m ()
m

addName :: MonadReader LetFinderCtx m => ParserName -> m b -> m b
addName :: ParserName -> m b -> m b
addName ParserName
x = (HashSet ParserName -> HashSet ParserName) -> m b -> m b
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
local (ParserName -> HashSet ParserName -> HashSet ParserName
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 :: Fix (Combinator :+: ScopeRegister) a -> ParserName
makeParserName !Fix (Combinator :+: ScopeRegister) a
p = IO ParserName -> ParserName
forall a. IO a -> a
unsafePerformIO ((StableName (Fix (Combinator :+: ScopeRegister) a) -> ParserName)
-> IO (StableName (Fix (Combinator :+: ScopeRegister) a))
-> IO ParserName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(StableName StableName# (Fix (Combinator :+: ScopeRegister) a)
name) -> StableName# (Fix (Combinator :+: ScopeRegister) a) -> ParserName
forall a.
StableName# (Fix (Combinator :+: ScopeRegister) a) -> ParserName
ParserName StableName# (Fix (Combinator :+: ScopeRegister) a)
name) (Fix (Combinator :+: ScopeRegister) a
-> IO (StableName (Fix (Combinator :+: ScopeRegister) a))
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 :: a -> IORef IΣVar
newRegMaker a
x = a
x a -> IORef IΣVar -> IORef IΣVar
`seq` IO (IORef IΣVar) -> IORef IΣVar
forall a. IO a -> a
unsafePerformIO (IΣVar -> IO (IORef IΣVar)
forall a. a -> IO (IORef a)
newIORef IΣVar
0)

{-# NOINLINE freshReg #-}
freshReg :: IORef IΣVar -> (forall r. Reg r a -> x) -> x
freshReg :: IORef IΣVar -> (forall r. Reg r a -> x) -> x
freshReg IORef IΣVar
maker forall r. Reg r a -> x
scope = Reg Any a -> x
forall r. Reg r a -> x
scope (Reg Any a -> x) -> Reg Any a -> x
forall a b. (a -> b) -> a -> b
$ IO (Reg Any a) -> Reg Any a
forall a. IO a -> a
unsafePerformIO (IO (Reg Any a) -> Reg Any a) -> IO (Reg Any a) -> Reg Any a
forall a b. (a -> b) -> a -> b
$ do
  IΣVar
x <- IORef IΣVar -> IO IΣVar
forall a. IORef a -> IO a
readIORef IORef IΣVar
maker
  IORef IΣVar -> IΣVar -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef IΣVar
maker (IΣVar
x IΣVar -> IΣVar -> IΣVar
forall a. Num a => a -> a -> a
+ IΣVar
1)
  Reg Any a -> IO (Reg Any a)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Reg Any a -> IO (Reg Any a)) -> Reg Any a -> IO (Reg Any a)
forall a b. (a -> b) -> a -> b
$! ΣVar a -> Reg Any a
forall r a. ΣVar a -> Reg r a
Reg (IΣVar -> ΣVar a
forall a. IΣVar -> ΣVar a
ΣVar IΣVar
x)

instance IFunctor f => IFunctor (Tag t f) where
  imap :: (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) = t -> f b i -> Tag t f b i
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 j. a j -> b j) -> f a i -> f b i
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) = StableName (Fix (Combinator :+: ScopeRegister) a)
-> StableName (Fix (Combinator :+: ScopeRegister) a) -> Bool
forall a b. StableName a -> StableName b -> Bool
eqStableName (StableName# (Fix (Combinator :+: ScopeRegister) a)
-> StableName (Fix (Combinator :+: ScopeRegister) a)
forall a. StableName# a -> StableName a
StableName StableName# (Fix (Combinator :+: ScopeRegister) a)
n) (StableName# (Fix (Combinator :+: ScopeRegister) a)
-> StableName (Fix (Combinator :+: ScopeRegister) a)
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) = StableName (Fix (Combinator :+: ScopeRegister) a) -> Int
forall a. StableName a -> Int
hashStableName (StableName# (Fix (Combinator :+: ScopeRegister) a)
-> StableName (Fix (Combinator :+: ScopeRegister) a)
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) = Int -> StableName (Fix (Combinator :+: ScopeRegister) a) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (StableName# (Fix (Combinator :+: ScopeRegister) a)
-> StableName (Fix (Combinator :+: ScopeRegister) a)
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 -> String -> String
showsPrec Int
_ (ParserName StableName# (Fix (Combinator :+: ScopeRegister) a)
n) = Int -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex (Int# -> Int
I# (StableName# (Fix (Combinator :+: ScopeRegister) a) -> Int#
unsafeCoerce# StableName# (Fix (Combinator :+: ScopeRegister) a)
n))