symantic-parser 0.0.0.20210102 → 0.1.0.20210201

raw patch · 88 files changed

+5731/−2320 lines, 88 filessetup-changedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +11/−0
• ReadMe.md +10/−8
• Setup.hs +138/−0
• ToDo.md +15/−5
• default.nix +4/−2
• flake.nix +1/−3
• src/Symantic/Parser.hs +8/−6
• src/Symantic/Parser/Grammar.hs +28/−21
• src/Symantic/Parser/Grammar/Combinators.hs +91/−60
• src/Symantic/Parser/Grammar/Dump.hs +0/−68
• src/Symantic/Parser/Grammar/ObserveSharing.hs +51/−47
• src/Symantic/Parser/Grammar/Optimize.hs +365/−396
• src/Symantic/Parser/Grammar/View.hs +74/−0
• src/Symantic/Parser/Grammar/Write.hs +81/−79
• src/Symantic/Parser/Haskell.hs +8/−215
• src/Symantic/Parser/Haskell/Optimize.hs +194/−0
• src/Symantic/Parser/Haskell/Term.hs +194/−0
• src/Symantic/Parser/Haskell/View.hs +114/−0
• src/Symantic/Parser/Machine.hs +24/−19
• src/Symantic/Parser/Machine/Dump.hs +0/−82
• src/Symantic/Parser/Machine/Generate.hs +306/−253
• src/Symantic/Parser/Machine/Input.hs +30/−23
• src/Symantic/Parser/Machine/Instructions.hs +110/−362
• src/Symantic/Parser/Machine/Optimize.hs +249/−0
• src/Symantic/Parser/Machine/Program.hs +196/−0
• src/Symantic/Parser/Machine/View.hs +92/−0
• src/Symantic/Univariant/Letable.hs +21/−4
• src/Symantic/Univariant/Trans.hs +2/−1
• symantic-parser.cabal +30/−9
• test/Golden.hs +41/−30
• test/Golden/Grammar.hs +0/−71
• test/Golden/Grammar/app.dump +2/−2
• test/Golden/Grammar/app.opt.dump +1/−1
• test/Golden/Grammar/boom.dump +27/−27
• test/Golden/Grammar/boom.opt.dump +22/−22
• test/Golden/Grammar/brainfuck.dump +65/−104
• test/Golden/Grammar/brainfuck.opt.dump +51/−80
• test/Golden/Grammar/many-a.dump +7/−7
• test/Golden/Grammar/many-a.opt.dump +5/−5
• test/Golden/Grammar/many-char-eof.dump +8/−8
• test/Golden/Grammar/many-char-eof.opt.dump +5/−5
• test/Golden/Grammar/many-char-fail.dump +0/−25
• test/Golden/Grammar/many-char-fail.opt.dump +0/−12
• test/Golden/Grammar/nandlang.dump +993/−0
• test/Golden/Grammar/nandlang.opt.dump +479/−0
• test/Golden/Grammar/string.dump +35/−0
• test/Golden/Grammar/string.opt.dump +10/−0
• test/Golden/Grammar/tokens.dump +35/−0
• test/Golden/Grammar/tokens.opt.dump +10/−0
• test/Golden/Grammar/unit-unit.dump +5/−5
• test/Golden/Grammar/unit-unit.opt.dump +4/−4
• test/Golden/Grammar/unit.dump +1/−1
• test/Golden/Grammar/unit.opt.dump +1/−1
• test/Golden/Machine/a-or-b.dump +8/−8
• test/Golden/Machine/app.dump +1/−1
• test/Golden/Machine/boom.dump +43/−43
• test/Golden/Machine/brainfuck.dump +79/−134
• test/Golden/Machine/eof.dump +4/−4
• test/Golden/Machine/many-a.dump +12/−12
• test/Golden/Machine/many-char-eof.dump +19/−19
• test/Golden/Machine/many-char-fail.dump +14/−14
• test/Golden/Machine/nandlang.dump +938/−0
• test/Golden/Machine/some-string.dump +42/−0
• test/Golden/Machine/string.dump +16/−0
• test/Golden/Machine/string.txt +1/−0
• test/Golden/Machine/unit-unit.dump +7/−7
• test/Golden/Machine/unit.dump +1/−1
• test/Golden/Parser/alt-right-notry.dump +1/−0
• test/Golden/Parser/alt-right-notry.txt +1/−0
• test/Golden/Parser/alt-right.dump +0/−1
• test/Golden/Parser/alt-right.txt +0/−1
• test/Golden/Parser/many-oneOf.dump +1/−0
• test/Golden/Parser/many-oneOf.txt +1/−0
• test/Golden/Parser/some-string-eof-fail.dump +1/−0
• test/Golden/Parser/some-string-eof-fail.txt +1/−0
• test/Golden/Parser/some-string-fail.dump +1/−0
• test/Golden/Parser/some-string-fail.txt +1/−0
• test/Golden/Parser/some-string.dump +1/−0
• test/Golden/Parser/some-string.txt +1/−0
• test/Golden/Parser/string-fail-horizon.dump +1/−0
• test/Golden/Parser/string-fail-horizon.txt +1/−0
• test/Golden/Parser/string.dump +1/−1
• test/Golden/Parser/string.txt +1/−1
• test/Golden/Splice/T1.hs +70/−0
• test/Parser.hs +8/−0
• test/Parser/Brainfuck.hs +47/−0
• test/Parser/Nandlang.hs +138/−0
• test/Parser/Playground.hs +15/−0

@@ -1,3 +1,14 @@+## symantic-parser-0.1.0.20210201++* Add error reporting using the farthest position reached.+* Add factoring of minimal input length checks ("horizon" checks).+* Open data-types `Comb` and `Instr`+  using a new technique based upon `data family` and `Typeable`.+* Leverage symantics further more to simplify the optimization passes.+* Rename some types and terms for clarity.+* Fix reproductibility of unit tests by hidding unique names.+* Add a few more tests.+ ## symantic-parser-0.0.0.20210102  * Add missing golden tests in the Cabal tarball.

@@ -1,19 +1,21 @@ ### Main differences with respect to `ParsleyHaskell` -- Tagless-final and `DefaultSignatures` are used instead of tagfull-final to handle recursion schemes, this avoids constructing and deconstructing as much tags when transforming combinators or instructions.-  And structures/simplifies the code by avoiding to define custom traversals (`traverseCombinator`) or custom fix-point data-types (`Fix4`) and associated utilities (`cata4`) when introducing new index-types. -  Note that the extensibility of combinators, a great feature of tagless-final, is not really achievable when using the optimizing pass which requires a comprehensive initial encoding.+- Extensible primitive grammar combinators, including their underlying optimization passes, by leveraging reciprocal injections between a tagless-final encoding of syntaxes (aka. type-classes) and a corresponding tagful-initial encoding to pattern-match syntaxes (aka. data-instances). This enable a very principled, yet flexible source code. Moreover `DefaultSignatures` are supplied to succinctly derive new semantics (aka. type-class-instances) using automatic `trans`formations. -- No dependency on `dependent-map` by keeping observed sharing inside `def` and `ref` combinators, instead of passing by a `DMap`. Same for join-points, where `TemplateHaskell` names are also directly used instead of passing by a `DMap`.+- Error messages based upon the farthest input position reached (not yet implemented in `ParsleyHaskell`). -- No dependency on GHC plugins: `lift-plugin` and `idioms-plugin`, because those are plugins hence introduce a bit of complexity in the build processes using this parser, but most importantly they are experimental and only cosmetic, since they only enable a cleaner usage of the parsing combinators, by lifting Haskell code in `pure` to integrate the `TemplateHaskell` needed. I do not understand them that much and do not feel confortable to maintain them in case their authors abandon them.+- Minimal input length checks ("horizon" checks) required for a successful parsing are factorized using a different static analysis than `ParsleyHaskell`'s "piggy bank" which I've not understood well. This analyis can see beyond calls to subroutines, but maybe `ParsleyHaskell`'s analysis can also be adjusted to do the same. Both analysis are not well documented and studied. -- Error messages based upon the farthest input position reached (not yet implemented in `ParsleyHaskell`).+- No dependency upon GHC plugins: `lift-plugin` and `idioms-plugin`, because those are plugins hence introduce a bit of complexity in the build processes using this parser, but most importantly they are experimental and mostly cosmetics, since they only enable a cleaner usage of the parsing combinators, by lifting Haskell code in `pure` to integrate the `TemplateHaskell` needed. I do not understand them that much and do not feel confortable to maintain them come the day that their authors abandon them. +- No dependency upon `dependent-map` by keeping observed sharing inside `def` and `ref` combinators, instead of passing by a `DMap`. And also when introducing the join-points optimization, where fresh `TemplateHaskell` names are also directly used instead of passing by a `DMap`.++- No support for general purpose registers in the `Machine` producing the `TemplateHaskell` splices (maybe it will come if I need and understand what's done in `ParsleyHaskell`).+ - License is `GPL-3.0-or-later` not `BSD-3-Clause`.  ### Main goals -- For me to better understand `ParsleyHaskell`, and find a manageable balance between simplicity of the codebase and features of the parser.+- For me to better understand [ParsleyHaskell](https://github.com/j-mie6/ParsleyHaskell), and find a manageable balance between simplicity of the codebase and features of the parser. And by doing so, challenging and showcasing symantic techniques. -- To support parsing tree-like data structures (like XML or HTTP routes) instead of just string-like data structures, which I've done using `megaparsec`, but it is not conceived for such input, and is less principled when it comes to optimizing, like merging alternatives.+- To support the parsing of tree-like data structures instead of only string-like data structures. Eg. to validate XML using RelaxNG in [symantic-xml](http://hackage.haskell.org/package/symantic-xml) or to perform routing of HTTP requests in [symantic-http-server](http://hackage.haskell.org/package/symantic-http-server). This is currently done in those packages using `megaparsec`, but `megaparsec` is not conceived for such input, and is less principled when it comes to optimizing, like merging alternatives.

@@ -0,0 +1,138 @@+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Control.Monad++import Data.List+import Data.String++import Distribution.PackageDescription+import Distribution.Simple+import Distribution.Simple.BuildPaths+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PackageIndex+import Distribution.Simple.Program+import Distribution.Simple.Setup+import Distribution.Simple.Utils+import Distribution.Text++import System.Directory+import System.FilePath++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+      generateBuildModule flags pkg lbi+      buildHook simpleUserHooks pkg lbi hooks flags+  , confHook = \(gpd, hbi) flags ->+      confHook simpleUserHooks (amendGPD gpd, hbi) flags+  , haddockHook = \pkg lbi hooks flags -> do+      generateBuildModule (haddockToBuildFlags flags) pkg lbi+      haddockHook simpleUserHooks pkg lbi hooks flags+  }++-- | Convert only flags used by 'generateBuildModule'.+haddockToBuildFlags :: HaddockFlags -> BuildFlags+haddockToBuildFlags f = emptyBuildFlags+    { buildVerbosity = haddockVerbosity f+    , buildDistPref  = haddockDistPref f+    }++generateBuildModule :: BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule flags pkg lbi = do+  rootDir <- getCurrentDirectory+  let verbosity = fromFlag (buildVerbosity flags)+      distPref  = fromFlag (buildDistPref flags)+      distPref' | isRelative distPref = rootDir </> distPref+                | otherwise           = distPref+      -- Package DBs+      dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref' </> "package.conf.inplace" ]+      dbFlags = "-hide-all-packages" : "-package-env=-" : packageDbArgsDb dbStack++      ghc = case lookupProgram ghcProgram (withPrograms lbi) of+              Just fp -> locationPath $ programLocation fp+              Nothing -> error "Can't find GHC path"+  withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testSuiteName) $ do+    let testAutogenDir = autogenComponentModulesDir lbi suitecfg+    createDirectoryIfMissingVerbose verbosity True testAutogenDir+    let buildSingletonsBaseFile = testAutogenDir </> buildSingletonsBaseModule <.> "hs"+    withLibLBI pkg lbi $ \_ libCLBI -> do+      let libDeps = map fst $ componentPackageDeps libCLBI+          pidx = case dependencyClosure (installedPkgs lbi) libDeps of+                   Left p  -> p+                   Right _ -> error "Broken dependency closure"+          libTransDeps = map installedUnitId $ allPackages pidx+          singletonsBaseUnitId = componentUnitId libCLBI+          deps = formatDeps (singletonsBaseUnitId:libTransDeps)+          allFlags = dbFlags ++ deps+      writeFile buildSingletonsBaseFile $ unlines+        [ "module Build_singletons_base where"+        , ""+        , "ghcPath :: FilePath"+        , "ghcPath = " ++ show ghc+        , ""+        , "ghcFlags :: [String]"+        , "ghcFlags = " ++ show allFlags+        , ""+        , "rootDir :: FilePath"+        , "rootDir = " ++ show rootDir+        ]+  where+    formatDeps = map formatOne+    formatOne installedPkgId = "-package-id=" ++ display installedPkgId++    -- GHC >= 7.6 uses the '-package-db' flag. See+    -- https://ghc.haskell.org/trac/ghc/ticket/5977.+    packageDbArgsDb :: [PackageDB] -> [String]+    -- special cases to make arguments prettier in common scenarios+    packageDbArgsDb dbstack = case dbstack of+      (GlobalPackageDB:UserPackageDB:dbs)+        | all isSpecific dbs              -> concatMap single dbs+      (GlobalPackageDB:dbs)+        | all isSpecific dbs              -> "-no-user-package-db"+                                           : concatMap single dbs+      dbs                                 -> "-clear-package-db"+                                           : concatMap single dbs+     where+       single (SpecificPackageDB db) = [ "-package-db=" ++ db ]+       single GlobalPackageDB        = [ "-global-package-db" ]+       single UserPackageDB          = [ "-user-package-db" ]+       isSpecific (SpecificPackageDB _) = True+       isSpecific _                     = False++buildSingletonsBaseModule :: FilePath+buildSingletonsBaseModule = "Build_singletons_base"++testSuiteName :: String+testSuiteName = "singletons-base-test-suite"++amendGPD :: GenericPackageDescription -> GenericPackageDescription+amendGPD gpd = gpd+    { condTestSuites = map f (condTestSuites gpd)+    }+  where+    f (name, condTree)+        | name == fromString testSuiteName = (name, condTree')+        | otherwise                        = (name, condTree)+      where+        -- I miss 'lens'+        testSuite = condTreeData condTree+        bi = testBuildInfo testSuite+        om = otherModules bi+        am = autogenModules bi++        -- Cons the module to both other-modules and autogen-modules.+        -- At the moment, cabal-spec-2.0 and cabal-spec-2.2 don't have+        -- "all autogen-modules are other-modules if they aren't exposed-modules"+        -- rule. Hopefully cabal-spec-3.0 will have.+        --+        -- Note: we `nub`, because it's unclear if that's ok to have duplicate+        -- modules in the lists.+        om' = nub $ mn : om+        am' = nub $ mn : am++        mn = fromString buildSingletonsBaseModule++        bi' = bi { otherModules = om', autogenModules = am' }+        testSuite' = testSuite { testBuildInfo = bi' }+        condTree' = condTree { condTreeData = testSuite' }

@@ -1,12 +1,22 @@-- [ ] Factorize input size checks (like Parsley's piggy bank).+- [ ] Error messages also based upon: [A Parsing Machine for Parsing Expression Grammars with Labeled Failures](https://dl.acm.org/doi/10.1145/2851613.2851750)  - [ ] Golden tests using more complex grammars.  - [ ] Error messages also based upon: [A Parsing Machine for Parsing Expression Grammars with Labeled Failures](https://dl.acm.org/doi/10.1145/2851613.2851750) -- [ ] Consider introducing registers like in ParsleyHaskell.--- [ ] Concerning the unusual `pure :: H.Haskell a -> repr a`,-  it may be acceptable to use `H.Haskell` only internally.+- [ ] Concerning the unusual `pure :: H.Term pure a -> repr a`,+  it may be acceptable to use `H.Term` only internally.  - [ ] Move the `Symantic.Univariant.*` modules into a separate package, maybe `symantic-base`.++- [ ] Golden tests for TH splices as in `singleton`.+      Note that the custom `Setup.hs` to get `ghcFlags` requires `cabal-install-3.4` which does not compile in Nixpkgs yet.++- [ ] Support parsing tree inputs (eg. RelaxNG in `symantic-xml` or HTTP routing in `symantic-http-server`).++- [ ] Consider introducing registers like in ParsleyHaskell.+      The custom `Setup.hs` requires `cabal-install-3.4`+      which does not compile in Nixpkgs yet.++- [ ] Study if the generated parser can easily and without much costs be made reentrant like `attoparsec`.+      In which case it could maybe replace `attoparsec` in `pipes`.

@@ -8,7 +8,8 @@     then pkgs.haskellPackages     else pkgs.haskell.packages.${ghc};   hs = haskellPackages.extend (with pkgs.haskell.lib;-    hself: hsuper: {+    hself: hsuper:+    {       data-fix = doJailbreak hsuper.data-fix;       primitive = doJailbreak hsuper.primitive;       assoc = doJailbreak hsuper.assoc;@@ -25,8 +26,9 @@   shell = hs.shellFor {     packages = p: [ p.symantic-parser ];     nativeBuildInputs = [-      pkgs.cabal-install+      #pkgs.cabal-install       #hs.cabal-install+      pkgs.cabal-install       #hs.haskell-language-server       #hs.hpc     ];

@@ -6,9 +6,7 @@     pkgs = inputs.nixpkgs.legacyPackages.${system};     in {       defaultPackage = import ./default.nix { inherit pkgs; };-      devShell = (import ./default.nix {-        inherit pkgs;-      }).shell;+      devShell = (import ./default.nix { inherit pkgs; }).shell;     }   ); }

@@ -1,14 +1,15 @@ {-# LANGUAGE TemplateHaskell #-} module Symantic.Parser- ( module Symantic.Parser.Grammar- , module Symantic.Parser.Machine- , module Symantic.Parser- ) where+  ( module Symantic.Parser.Grammar+  , module Symantic.Parser.Machine+  , module Symantic.Parser+  ) where  import Data.Either (Either(..)) import Data.Ord (Ord) import Language.Haskell.TH (CodeQ) import Text.Show (Show)+import Type.Reflection (Typeable) import qualified Language.Haskell.TH.Syntax as TH  import Symantic.Parser.Grammar@@ -18,9 +19,10 @@   Ord (InputToken inp) =>   Show (InputToken inp) =>   TH.Lift (InputToken inp) =>+  Typeable (InputToken inp) =>   -- InputToken inp ~ Char =>   Input inp =>-  Readable Gen (InputToken inp) =>+  Readable (InputToken inp) Gen =>   Parser inp a ->   CodeQ (inp -> Either (ParsingError inp) a)-runParser p = [|| \input -> $$(generate [||input||] (machine p)) ||]+runParser p = [|| \input -> $$(generateCode [||input||] (machine p)) ||]

@@ -1,32 +1,32 @@+{-# LANGUAGE AllowAmbiguousTypes #-} -- For grammar {-# LANGUAGE ConstraintKinds #-} -- For Grammar module Symantic.Parser.Grammar- ( module Symantic.Parser.Grammar- , module Symantic.Parser.Grammar.Combinators- , module Symantic.Parser.Grammar.Fixity- , module Symantic.Parser.Grammar.Optimize- , module Symantic.Parser.Grammar.ObserveSharing- , module Symantic.Parser.Grammar.Write- , module Symantic.Parser.Grammar.Dump- , Letable(..)- ) where+  ( module Symantic.Parser.Grammar+  , module Symantic.Parser.Grammar.Combinators+  , module Symantic.Parser.Grammar.Fixity+  , module Symantic.Parser.Grammar.Optimize+  , module Symantic.Parser.Grammar.ObserveSharing+  , module Symantic.Parser.Grammar.Write+  , module Symantic.Parser.Grammar.View+  , Letable(..)+  ) where import Symantic.Parser.Grammar.Combinators-import Symantic.Parser.Grammar.Dump+import Symantic.Parser.Grammar.View import Symantic.Parser.Grammar.Fixity import Symantic.Parser.Grammar.ObserveSharing import Symantic.Parser.Grammar.Optimize import Symantic.Parser.Grammar.Write-import Symantic.Univariant.Letable (Letable(..))  import Data.Function ((.)) import Data.String (String) import Text.Show (Show(..)) import qualified Language.Haskell.TH.Syntax as TH --- Class 'Grammar'-type Grammar repr =+-- * Class 'Grammar'+type Grammar tok repr =   ( Applicable repr   , Alternable repr-  --, Satisfiable repr+  , Satisfiable tok repr   , Letable TH.Name repr   , Selectable repr   , Matchable repr@@ -35,11 +35,18 @@   )  -- | A usual pipeline to interpret 'Comb'inators:--- 'observeSharing' then 'optimizeComb' then a polymorphic @(repr)@.-grammar :: Grammar repr => ObserveSharing TH.Name (OptimizeComb TH.Name repr) a -> repr a-grammar = optimizeComb . observeSharing+-- 'observeSharing' then 'optimizeGrammar' then a polymorphic @(repr)@.+grammar ::+  Grammar tok repr =>+  ObserveSharing TH.Name+    (OptimizeGrammar repr) a ->+  repr a+grammar = optimizeGrammar . observeSharing --- | A usual pipeline to show 'Comb'inators:--- 'observeSharing' then 'optimizeComb' then 'dumpComb' then 'show'.-showGrammar :: ObserveSharing TH.Name (OptimizeComb TH.Name DumpComb) a -> String-showGrammar = show . dumpComb . optimizeComb . observeSharing+-- | An usual pipeline to show 'Comb'inators:+-- 'observeSharing' then 'optimizeGrammar' then 'viewGrammar' then 'show'.+showGrammar ::+  ObserveSharing TH.Name+    (OptimizeGrammar (ViewGrammar showName)) a ->+  String+showGrammar = show . viewGrammar . optimizeGrammar . observeSharing

@@ -8,6 +8,8 @@ {-# LANGUAGE DeriveLift #-} -- For TH.Lift (ErrorItem tok) {-# LANGUAGE StandaloneDeriving #-} -- For Show (ErrorItem (InputToken inp)) {-# LANGUAGE TemplateHaskell #-}+-- | Semantic of the grammar combinators used to express parsers,+-- in the convenient tagless-final encoding. module Symantic.Parser.Grammar.Combinators where  import Data.Bool (Bool(..), not, (||))@@ -19,45 +21,48 @@ import Data.Maybe (Maybe(..)) import Data.Ord (Ord) import Data.String (String)-import Language.Haskell.TH (CodeQ) import Text.Show (Show(..)) import qualified Data.Functor as Functor import qualified Data.List as List+import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH  import qualified Symantic.Univariant.Trans as Sym import qualified Symantic.Parser.Haskell as H +-- * Type 'TermGrammar'+type TermGrammar = H.Term H.ValueCode+ -- * Class 'Applicable' -- | This is like the usual 'Functor' and 'Applicative' type classes--- from the @base@ package, but using @('H.Haskell' a)@ instead of just @(a)@--- to be able to use and pattern match on some usual terms of type @(a)@ (like--- 'H.id') and thus apply some optimizations.--- @(repr)@ , for "representation", is the usual tagless-final abstraction+-- from the @base@ package, but using @('TermGrammar' a)@ instead of just @(a)@+-- to be able to use and pattern match on some usual terms of type @(a)@ (like 'H.id')+-- and thus apply some optimizations.+-- @(repr)@, for "representation", is the usual tagless-final abstraction -- over the many semantics that this syntax (formed by the methods -- of type class like this one) will be interpreted. class Applicable repr where   -- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.-  (<$>) :: H.Haskell (a -> b) -> repr a -> repr b+  (<$>) :: TermGrammar (a -> b) -> repr a -> repr b   (<$>) f = (pure f <*>)    -- | Like '<$>' but with its arguments 'flip'-ped.-  (<&>) :: repr a -> H.Haskell (a -> b) -> repr b+  (<&>) :: repr a -> TermGrammar (a -> b) -> repr b   (<&>) = flip (<$>)    -- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.-  (<$) :: H.Haskell a -> repr b -> repr a+  (<$) :: TermGrammar a -> repr b -> repr a   (<$) x = (pure x <*)    -- | @(ra '$>' b)@ parses like @(ra)@ but discards its returned value by replacing it with @(b)@.-  ($>) :: repr a -> H.Haskell b -> repr b+  ($>) :: repr a -> TermGrammar b -> repr b   ($>) = flip (<$)    -- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.-  pure :: H.Haskell a -> repr a+  pure :: TermGrammar a -> repr a   default pure ::     Sym.Liftable repr => Applicable (Sym.Output repr) =>-    H.Haskell a -> repr a+    TermGrammar a -> repr a   pure = Sym.lift . pure    -- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,@@ -71,7 +76,7 @@    -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@,   -- and returns the application of @(a2b2c)@ to the values returned by those parsers.-  liftA2 :: H.Haskell (a -> b -> c) -> repr a -> repr b -> repr c+  liftA2 :: TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c   liftA2 f x = (<*>) (f <$> x)    -- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@,@@ -124,13 +129,13 @@   p <+> q = H.left <$> p <|> H.right <$> q infixl 3 <|>, <+> -optionally :: Applicable repr => Alternable repr => repr a -> H.Haskell b -> repr b+optionally :: Applicable repr => Alternable repr => repr a -> TermGrammar b -> repr b optionally p x = p $> x <|> pure x  optional :: Applicable repr => Alternable repr => repr a -> repr () optional = flip optionally H.unit -option :: Applicable repr => Alternable repr => H.Haskell a -> repr a -> repr a+option :: Applicable repr => Alternable repr => TermGrammar a -> repr a -> repr a option x p = p <|> pure x  choice :: Alternable repr => [repr a] -> repr a@@ -155,14 +160,15 @@ -- * Class 'Matchable' class Matchable repr where   conditional ::-    Eq a => [H.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b+    Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b   default conditional ::-    Sym.Unliftable repr => Sym.Liftable2 repr => Matchable (Sym.Output repr) =>-    Eq a => [H.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b-  conditional cs bs = Sym.lift2 (conditional cs (Sym.trans Functor.<$> bs))+    Sym.Unliftable repr => Sym.Liftable1 repr => Matchable (Sym.Output repr) =>+    Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b+  conditional a ps bs = Sym.lift1 (conditional (Sym.trans a) ps (Sym.trans Functor.<$> bs)) -  match :: Eq a => [H.Haskell a] -> repr a -> (H.Haskell a -> repr b) -> repr b -> repr b-  match as a a2b = conditional (H.eq Functor.<$> as) (a2b Functor.<$> as) a+  match :: Eq a => repr a -> [TermGrammar a] -> (TermGrammar a -> repr b) -> repr b -> repr b+  match a as a2b = conditional a ((H.eq H..@) Functor.<$> as) (a2b Functor.<$> as)+  -- match a as a2b = conditional a (((H.eq H..@ H.qual) H..@) Functor.<$> as) (a2b Functor.<$> as)  -- * Class 'Foldable' class Foldable repr where@@ -192,24 +198,28 @@     where go = (H..) <$> op <*> go <|> pure H.id  {--conditional :: Selectable repr => [(H.Haskell (a -> Bool), repr b)] -> repr a -> repr b -> repr b+conditional :: Selectable repr => [(TermGrammar (a -> Bool), repr b)] -> repr a -> repr b -> repr b conditional cs p def = match p fs qs def   where (fs, qs) = List.unzip cs -}  -- * Class 'Satisfiable'-class Satisfiable repr tok where-  satisfy :: [ErrorItem tok] -> H.Haskell (tok -> Bool) -> repr tok+class Satisfiable tok repr where+  satisfy :: [ErrorItem tok] -> TermGrammar (tok -> Bool) -> repr tok   default satisfy ::-    Sym.Liftable repr => Satisfiable (Sym.Output repr) tok =>+    Sym.Liftable repr => Satisfiable tok (Sym.Output repr) =>     [ErrorItem tok] ->-    H.Haskell (tok -> Bool) -> repr tok+    TermGrammar (tok -> Bool) -> repr tok   satisfy es = Sym.lift . satisfy es +  item :: repr tok+  item = satisfy [] (H.const H..@ H.bool True)+ -- ** Type 'ErrorItem' data ErrorItem tok   =  ErrorItemToken tok   |  ErrorItemLabel String+  |  ErrorItemHorizon Int   |  ErrorItemEnd deriving instance Eq tok => Eq (ErrorItem tok) deriving instance Ord tok => Ord (ErrorItem tok)@@ -228,8 +238,8 @@   eof :: repr ()   eof = Sym.lift eof   default eof :: Sym.Liftable repr => Lookable (Sym.Output repr) => repr ()-  -- eof = negLook (satisfy @_ @Char [ErrorItemAny] (H.const H..@ H.bool True))-             -- (item @_ @Char)+  -- eof = negLook (satisfy @Char [ErrorItemAny] (H.const H..@ H.bool True))+             -- (item @Char)  {-# INLINE (<:>) #-} infixl 4 <:>@@ -250,43 +260,64 @@ between :: Applicable repr => repr o -> repr c -> repr a -> repr a between open close p = open *> p <* close -string :: Applicable repr => Satisfiable repr Char => [Char] -> repr [Char]-string = traverse char+string ::+  Applicable repr => Alternable repr =>+  Satisfiable Char repr =>+  [Char] -> repr [Char]+string = try . traverse char --- oneOf :: [Char] -> repr Char--- oneOf cs = satisfy [] (makeQ (flip elem cs) [||\c -> $$(ofChars cs [||c||])||])+oneOf ::+  TH.Lift tok => Eq tok =>+  Satisfiable tok repr =>+  [tok] -> repr tok+oneOf ts = satisfy [ErrorItemLabel "oneOf"]+  (Sym.trans H.ValueCode+    { value = (`List.elem` ts)+    , code = [||\t -> $$(ofChars ts [||t||])||] }) -noneOf :: TH.Lift tok => Eq tok => Satisfiable repr tok => [tok] -> repr tok-noneOf cs = satisfy (ErrorItemToken Functor.<$> cs) (H.Haskell H.ValueCode{..})-  where-  value = H.Value (not . flip List.elem cs)-  code = [||\c -> not $$(ofChars cs [||c||])||]+noneOf ::+  TH.Lift tok => Eq tok =>+  Satisfiable tok repr =>+  [tok] -> repr tok+noneOf cs = satisfy (ErrorItemToken Functor.<$> cs) (Sym.trans H.ValueCode+  { value = not . (`List.elem` cs)+  , code = [||\c -> not $$(ofChars cs [||c||])||]+  }) -ofChars :: TH.Lift tok => Eq tok => [tok] -> CodeQ tok -> CodeQ Bool-ofChars = List.foldr (\c rest qc -> [|| c == $$qc || $$(rest qc) ||]) (const [||False||])+ofChars ::+  TH.Lift tok => Eq tok =>+  {-alternatives-}[tok] ->+  {-input-}TH.CodeQ tok ->+  TH.CodeQ Bool+ofChars = List.foldr (\alt acc ->+  \inp -> [|| alt == $$inp || $$(acc inp) ||])+  (const [||False||]) -more :: Applicable repr => Satisfiable repr Char => Lookable repr => repr ()-more = look (void (item @_ @Char))+more :: Applicable repr => Satisfiable Char repr => Lookable repr => repr ()+more = look (void (item @Char)) -char :: Applicable repr => Satisfiable repr Char => Char -> repr Char-char c = satisfy [ErrorItemToken c] (H.eq (H.char c)) $> H.char c+char ::+  Applicable repr => Satisfiable Char repr =>+  Char -> repr Char+char c = satisfy [ErrorItemToken c] (H.eq H..@ H.char c) $> H.char c+-- char c = satisfy [ErrorItemToken c] (H.eq H..@ H.qual H..@ H.char c) $> H.char c -anyChar :: Satisfiable repr Char => repr Char+anyChar :: Satisfiable Char repr => repr Char anyChar = satisfy [] (H.const H..@ H.bool True)  token ::-  TH.Lift tok => Eq tok => Applicable repr =>-  Satisfiable repr tok => tok -> repr tok-token tok = satisfy [ErrorItemToken tok] (H.eq (H.char tok)) $> H.char tok+  TH.Lift tok => Show tok => Eq tok =>+  Applicable repr => Satisfiable tok repr =>+  tok -> repr tok+token tok = satisfy [ErrorItemToken tok] (H.eq H..@ H.char tok) $> H.char tok+-- token tok = satisfy [ErrorItemToken tok] (H.eq H..@ H.qual H..@ H.char tok) $> H.char tok  tokens ::-  TH.Lift tok => Eq tok => Applicable repr => Alternable repr =>-  Satisfiable repr tok => [tok] -> repr [tok]+  TH.Lift tok => Eq tok => Show tok =>+  Applicable repr => Alternable repr =>+  Satisfiable tok repr => [tok] -> repr [tok] tokens = try . traverse token -item :: Satisfiable repr tok => repr tok-item = satisfy [] (H.const H..@ H.bool True)- -- Composite Combinators -- someTill :: repr a -> repr b -> repr [a] -- someTill p end = negLook end *> (p <:> manyTill p end)@@ -324,12 +355,12 @@ -- Lift Operations liftA2 ::  Applicable repr =>- H.Haskell (a -> b -> c) -> repr a -> repr b -> repr c+ TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c liftA2 f x = (<*>) (fmap f x)  liftA3 ::  Applicable repr =>- H.Haskell (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d+ TermGrammar (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d liftA3 f a b c = liftA2 f a b <*> c  -}@@ -337,28 +368,28 @@ -- Parser Folds pfoldr ::  Applicable repr => Foldable repr =>- H.Haskell (a -> b -> b) -> H.Haskell b -> repr a -> repr b+ TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b pfoldr f k p = chainPre (f <$> p) (pure k)  pfoldr1 ::  Applicable repr => Foldable repr =>- H.Haskell (a -> b -> b) -> H.Haskell b -> repr a -> repr b+ TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b pfoldr1 f k p = f <$> p <*> pfoldr f k p  pfoldl ::  Applicable repr => Foldable repr =>- H.Haskell (b -> a -> b) -> H.Haskell b -> repr a -> repr b+ TermGrammar (b -> a -> b) -> TermGrammar b -> repr a -> repr b pfoldl f k p = chainPost (pure k) ((H.flip <$> pure f) <*> p)  pfoldl1 ::  Applicable repr => Foldable repr =>- H.Haskell (b -> a -> b) -> H.Haskell b -> repr a -> repr b+ TermGrammar (b -> a -> b) -> TermGrammar b -> repr a -> repr b pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((H.flip <$> pure f) <*> p)  -- Chain Combinators chainl1' ::  Applicable repr => Foldable repr =>- H.Haskell (a -> b) -> repr a -> repr (b -> a -> b) -> repr b+ TermGrammar (a -> b) -> repr a -> repr (b -> a -> b) -> repr b chainl1' f p op = chainPost (f <$> p) (H.flip <$> op <*> p)  chainl1 ::@@ -377,13 +408,13 @@ chainr1 :: repr a -> repr (a -> a -> a) -> repr a chainr1 = chainr1' H.id -chainr :: repr a -> repr (a -> a -> a) -> H.Haskell a -> repr a+chainr :: repr a -> repr (a -> a -> a) -> TermGrammar a -> repr a chainr p op x = option x (chainr1 p op) -}  chainl ::  Applicable repr => Alternable repr => Foldable repr =>- repr a -> repr (a -> a -> a) -> H.Haskell a -> repr a+ repr a -> repr (a -> a -> a) -> TermGrammar a -> repr a chainl p op x = option x (chainl1 p op)  -- Derived Combinators

@@ -1,68 +0,0 @@-module Symantic.Parser.Grammar.Dump where--import Data.Function (($), (.), id)-import Data.Semigroup (Semigroup(..))-import Data.String (String, IsString(..))-import Text.Show (Show(..))-import qualified Control.Applicative as Fct-import qualified Data.Tree as Tree-import qualified Data.List as List--import Symantic.Univariant.Letable-import Symantic.Parser.Grammar.Combinators---- * Type 'DumpComb'-newtype DumpComb a = DumpComb { unDumpComb :: Tree.Tree String }--dumpComb :: DumpComb a -> DumpComb a-dumpComb = id--instance Show (DumpComb a) where-  show = drawTree . unDumpComb-    where-    drawTree :: Tree.Tree String -> String-    drawTree  = List.unlines . draw-    draw :: Tree.Tree String -> [String]-    draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0-      where-      drawSubTrees [] = []-      drawSubTrees [t] = shift "` " "  " (draw t)-      drawSubTrees (t:ts) = shift "+ " "| " (draw t) <> drawSubTrees ts-      shift first other = List.zipWith (<>) (first : List.repeat other)-instance IsString (DumpComb a) where-  fromString s = DumpComb $ Tree.Node (fromString s) []--instance Show letName => Letable letName DumpComb where-  def name x = DumpComb $-    Tree.Node ("def "<>show name) [unDumpComb x]-  ref rec name = DumpComb $-    Tree.Node-      ( (if rec then "rec " else "ref ")-      <> show name-      ) []-instance Applicable DumpComb where-  _f <$> x = DumpComb $ Tree.Node "<$>" [unDumpComb x]-  pure a = DumpComb $ Tree.Node ("pure "<>showsPrec 10 a "") []-  x <*> y = DumpComb $ Tree.Node "<*>" [unDumpComb x, unDumpComb y]-instance Alternable DumpComb where-  empty = DumpComb $ Tree.Node "empty" []-  x <|> y = DumpComb $ Tree.Node "<|>" [unDumpComb x, unDumpComb y]-  try x = DumpComb $ Tree.Node "try" [unDumpComb x]-instance Satisfiable DumpComb tok where-  satisfy _es _p = DumpComb $ Tree.Node "satisfy" []-instance Selectable DumpComb where-  branch lr l r = DumpComb $ Tree.Node "branch"-    [ unDumpComb lr, unDumpComb l, unDumpComb r ]-instance Matchable DumpComb where-  conditional _cs bs a b = DumpComb $ Tree.Node "conditional"-    [ Tree.Node "bs" (unDumpComb Fct.<$> bs)-    , unDumpComb a-    , unDumpComb b-    ]-instance Lookable DumpComb where-  look x = DumpComb $ Tree.Node "look" [unDumpComb x]-  negLook x = DumpComb $ Tree.Node "negLook" [unDumpComb x]-  eof = DumpComb $ Tree.Node "eof" []-instance Foldable DumpComb where-  chainPre f x = DumpComb $ Tree.Node "chainPre" [unDumpComb f, unDumpComb x]-  chainPost x f = DumpComb $ Tree.Node "chainPost" [unDumpComb x, unDumpComb f]

@@ -1,107 +1,111 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Symantic.Parser.Grammar.ObserveSharing- ( module Symantic.Parser.Grammar.ObserveSharing- , ObserveSharing(..)- ) where+  ( module Symantic.Univariant.Letable+  , module Symantic.Parser.Grammar.ObserveSharing+  ) where  import Control.Monad (mapM)-import Control.Applicative (Applicative(..)) import Data.Eq (Eq(..)) import Data.Function (($), (.))-import Data.Functor ((<$>)) import Data.Hashable (Hashable, hashWithSalt) import Text.Show (Show(..))+import qualified Control.Applicative as Functor -import Symantic.Univariant.Letable as Letable-import qualified Symantic.Univariant.Trans as Sym-import qualified Symantic.Parser.Grammar.Combinators as Comb+import Symantic.Parser.Grammar.Combinators+import Symantic.Univariant.Letable hiding (observeSharing)+import qualified Symantic.Univariant.Letable as Letable import qualified Language.Haskell.TH.Syntax as TH+import qualified Symantic.Univariant.Trans as Sym  -- | Like 'Letable.observeSharing'--- but type-binding @(letName)@ to 'TH.Name' to help type inference.+-- but type-binding @(letName)@ to 'TH.Name'+-- to avoid the trouble to always set it. observeSharing :: ObserveSharing TH.Name repr a -> repr a observeSharing = Letable.observeSharing +-- | Needed by 'observeSharing'. instance Hashable TH.Name where   hashWithSalt s = hashWithSalt s . show --- Combinators semantics for the 'ObserveSharing' interpreter+-- Combinators semantics for the 'ObserveSharing' interpreter. instance   ( Letable letName repr   , MakeLetName letName   , Eq letName   , Hashable letName-  , Comb.Satisfiable repr tok-  ) => Comb.Satisfiable (ObserveSharing letName repr) tok+  , Satisfiable tok repr+  ) => Satisfiable tok (ObserveSharing letName repr) instance   ( Letable letName repr   , MakeLetName letName   , Eq letName   , Hashable letName-  , Comb.Alternable repr-  ) => Comb.Alternable (ObserveSharing letName repr)+  , Alternable repr+  ) => Alternable (ObserveSharing letName repr) instance   ( Letable letName repr   , MakeLetName letName   , Eq letName   , Hashable letName-  , Comb.Applicable repr-  ) => Comb.Applicable (ObserveSharing letName repr)+  , Applicable repr+  ) => Applicable (ObserveSharing letName repr) instance   ( Letable letName repr   , MakeLetName letName   , Eq letName   , Hashable letName-  , Comb.Selectable repr-  ) => Comb.Selectable (ObserveSharing letName repr)+  , Selectable repr+  ) => Selectable (ObserveSharing letName repr) instance   ( Letable letName repr   , MakeLetName letName   , Eq letName   , Hashable letName-  , Comb.Matchable repr-  ) => Comb.Matchable (ObserveSharing letName repr) where+  , Matchable repr+  ) => Matchable (ObserveSharing letName repr) where   -- Here the default definition does not fit   -- since there is no lift* for the type of 'conditional'-  -- and its default definition handles does not handles 'bs'+  -- and its default definition does not handles 'bs'   -- as needed by the 'ObserveSharing' transformation.-  conditional cs bs a b = observeSharingNode $ ObserveSharing $-    Comb.conditional cs-      <$> mapM unObserveSharing bs-      <*> unObserveSharing a-      <*> unObserveSharing b+  conditional a cs bs b = observeSharingNode $ ObserveSharing $+    conditional+      Functor.<$> unObserveSharing a+      Functor.<*> Functor.pure cs+      Functor.<*> mapM unObserveSharing bs+      Functor.<*> unObserveSharing b instance   ( Letable letName repr   , MakeLetName letName   , Eq letName   , Hashable letName-  , Comb.Foldable repr+  , Foldable repr   {- TODO: the following constraints are for the current Foldable,    - they will have to be removed when Foldable will have Sym.lift2 as defaults    -}-  , Comb.Applicable repr-  , Comb.Alternable repr-  ) => Comb.Foldable (ObserveSharing letName repr)+  , Applicable repr+  , Alternable repr+  ) => Foldable (ObserveSharing letName repr) instance   ( Letable letName repr   , MakeLetName letName   , Eq letName   , Hashable letName-  , Comb.Lookable repr-  ) => Comb.Lookable (ObserveSharing letName repr)+  , Lookable repr+  ) => Lookable (ObserveSharing letName repr) --- Combinators semantics for the 'CleanDefs' interpreter-instance Comb.Applicable repr => Comb.Applicable (CleanDefs letName repr)-instance Comb.Alternable repr => Comb.Alternable (CleanDefs letName repr)-instance Comb.Satisfiable repr tok => Comb.Satisfiable (CleanDefs letName repr) tok-instance Comb.Selectable repr => Comb.Selectable (CleanDefs letName repr)-instance Comb.Matchable repr => Comb.Matchable (CleanDefs letName repr) where-  conditional cs bs a b = CleanDefs $-    Comb.conditional cs-      <$> mapM unCleanDefs bs-      <*> unCleanDefs a-      <*> unCleanDefs b-instance Comb.Lookable repr => Comb.Lookable (CleanDefs letName repr)-instance Comb.Foldable repr => Comb.Foldable (CleanDefs letName repr) where-  chainPre = Sym.lift2 Comb.chainPre-  chainPost = Sym.lift2 Comb.chainPost+-- Combinators semantics for the 'CleanDefs' interpreter.+instance Applicable repr => Applicable (CleanDefs letName repr)+instance Alternable repr => Alternable (CleanDefs letName repr)+instance Satisfiable tok repr => Satisfiable tok (CleanDefs letName repr)+instance Selectable repr => Selectable (CleanDefs letName repr)+instance Matchable repr => Matchable (CleanDefs letName repr) where+  conditional a cs bs b = CleanDefs $+    conditional+      Functor.<$> unCleanDefs a+      Functor.<*> Functor.pure cs+      Functor.<*> mapM unCleanDefs bs+      Functor.<*> unCleanDefs b+instance Lookable repr => Lookable (CleanDefs letName repr)+instance Foldable repr => Foldable (CleanDefs letName repr) where+  chainPre = Sym.lift2 chainPre+  chainPost = Sym.lift2 chainPost

@@ -1,440 +1,409 @@-{-# LANGUAGE PatternSynonyms #-} -- For aliased combinators-{-# LANGUAGE TemplateHaskell #-} -- For optimizeCombNode-{-# LANGUAGE ViewPatterns #-} -- For optimizeCombNode+{-# LANGUAGE PatternSynonyms #-} -- For Comb+{-# LANGUAGE TemplateHaskell #-} -- For branch+{-# LANGUAGE ViewPatterns #-} -- For unSomeComb {-# OPTIONS_GHC -fno-warn-orphans #-} -- For MakeLetName TH.Name+-- | Bottom-up optimization of 'Comb'inators,+-- reexamining downward as needed after each optimization. module Symantic.Parser.Grammar.Optimize where  import Data.Bool (Bool(..)) import Data.Either (Either(..), either) import Data.Eq (Eq(..))-import Data.Foldable (all, foldr) import Data.Function ((.))-import Data.Kind (Type)+import Data.Maybe (Maybe(..)) import qualified Data.Functor as Functor+import qualified Data.Foldable as Foldable import qualified Data.List as List import qualified Language.Haskell.TH.Syntax as TH+import Data.Kind (Constraint, Type)+import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))  import Symantic.Parser.Grammar.Combinators as Comb-import Symantic.Parser.Haskell (ValueCode(..), Value(..), getValue, code)+import Symantic.Parser.Haskell () import Symantic.Univariant.Letable import Symantic.Univariant.Trans import qualified Symantic.Parser.Haskell as H --- import Debug.Trace (trace)+{- Uncomment to trace optimizations+import Data.Function (($), flip)+import Debug.Trace (trace) --- * Type 'Comb'--- | Pattern-matchable 'Comb'inators of the grammar.--- @(repr)@ is not strictly necessary since it's only a phantom type--- (no constructor use it as a value), but having it:------ 1. emphasizes that those 'Comb'inators will be 'trans'formed again---    (eg. in 'DumpComb' or 'Instr'uctions).------ 2. Avoid overlapping instances between---    @('Trans' ('Comb' repr) repr)@ and---    @('Trans' ('Comb' repr) ('OptimizeComb' letName repr))@-data Comb (repr :: Type -> Type) a where-  Pure :: H.Haskell a -> Comb repr a-  Satisfy ::-    Satisfiable repr tok =>-    [ErrorItem tok] ->-    H.Haskell (tok -> Bool) -> Comb repr tok-  Item :: Satisfiable repr tok => Comb repr tok-  Try :: Comb repr a -> Comb repr a-  Look :: Comb repr a -> Comb repr a-  NegLook :: Comb repr a -> Comb repr ()-  Eof :: Comb repr ()-  (:<*>) :: Comb repr (a -> b) -> Comb repr a -> Comb repr b-  (:<|>) :: Comb repr a -> Comb repr a -> Comb repr a-  Empty :: Comb repr a-  Branch ::-    Comb repr (Either a b) ->-    Comb repr (a -> c) -> Comb repr (b -> c) -> Comb repr c-  Match :: Eq a =>-    [H.Haskell (a -> Bool)] ->-    [Comb repr b] -> Comb repr a -> Comb repr b -> Comb repr b-  ChainPre :: Comb repr (a -> a) -> Comb repr a -> Comb repr a-  ChainPost :: Comb repr a -> Comb repr (a -> a) -> Comb repr a-  Def :: TH.Name -> Comb repr a -> Comb repr a-  Ref :: Bool -> TH.Name -> Comb repr a+(&) = flip ($)+infix 0 &+-} -pattern (:<$>) :: H.Haskell (a -> b) -> Comb repr a -> Comb repr b-pattern (:$>) :: Comb repr a -> H.Haskell b -> Comb repr b-pattern (:<$) :: H.Haskell a -> Comb repr b -> Comb repr a-pattern (:*>) :: Comb repr a -> Comb repr b -> Comb repr b-pattern (:<*) :: Comb repr a -> Comb repr b -> Comb repr a-pattern x :<$> p = Pure x :<*> p-pattern p :$> x = p :*> Pure x-pattern x :<$ p = Pure x :<* p-pattern x :<* p = H.Const :<$> x :<*> p-pattern p :*> x = H.Id :<$ p :<*> x+-- * Type 'OptimizeGrammar'+type OptimizeGrammar = SomeComb -infixl 3 :<|>-infixl 4 :<*>, :<*, :*>-infixl 4 :<$>, :<$, :$>+optimizeGrammar ::+  Trans (SomeComb repr) repr =>+  SomeComb repr a -> repr a+optimizeGrammar = trans -instance Applicable (Comb repr) where-  pure = Pure-  (<*>) = (:<*>)-instance Alternable (Comb repr) where-  (<|>) = (:<|>)-  empty = Empty-  try = Try-instance Selectable (Comb repr) where-  branch = Branch-instance Matchable (Comb repr) where-  conditional = Match-instance Foldable (Comb repr) where-  chainPre = ChainPre-  chainPost = ChainPost-instance Satisfiable repr tok => Satisfiable (Comb repr) tok where-  satisfy = Satisfy-instance Lookable (Comb repr) where-  look = Look-  negLook = NegLook-  eof = Eof-instance Letable TH.Name (Comb repr) where-  def = Def-  ref = Ref-instance MakeLetName TH.Name where-  makeLetName _ = TH.qNewName "name"+-- * Data family 'Comb'+-- | 'Comb'inators of the 'Grammar'.+-- This is an extensible data-type.+data family Comb+  (comb :: ReprComb -> Constraint)+  (repr :: ReprComb)+  :: ReprComb --- Pattern-matchable 'Comb'inators keep enough structure--- to have some of the symantics producing them interpreted again--- (eg. after being modified by 'optimizeComb').-type instance Output (Comb repr) = repr+-- | Convenient utility to pattern-match a 'SomeComb'.+pattern Comb :: Typeable comb =>+  Comb comb repr a ->+  SomeComb repr a+pattern Comb x <- (unSomeComb -> Just x)++-- ** Type 'ReprComb'+type ReprComb = Type -> Type++-- ** Type 'SomeComb'+-- | Some 'Comb'inator existentialized over the actual combinator symantic class.+-- Useful to handle a list of 'Comb'inators+-- without requiring impredicative quantification.+-- Must be used by pattern-matching+-- on the 'SomeComb' data-constructor,+-- to bring the constraints in scope.+--+-- The optimizations are directly applied within it,+-- to avoid introducing an extra newtype,+-- this also give a more comprehensible code.+data SomeComb repr a =+  forall comb.+  (Trans (Comb comb repr) repr, Typeable comb) =>+  SomeComb (Comb comb repr a)++instance Trans (SomeComb repr) repr where+  trans (SomeComb x) = trans x++-- | @(unSomeComb c :: 'Maybe' ('Comb' comb repr a))@+-- extract the data-constructor from the given 'SomeComb'+-- iif. it belongs to the @('Comb' comb repr a)@ data-instance.+unSomeComb ::+  forall comb repr a.+  Typeable comb =>+  SomeComb repr a -> Maybe (Comb comb repr a)+unSomeComb (SomeComb (c::Comb c repr a)) =+  case typeRep @comb `eqTypeRep` typeRep @c of+    Just HRefl -> Just c+    Nothing -> Nothing++-- Applicable+data instance Comb Applicable repr a where+  Pure :: TermGrammar a -> Comb Applicable repr a+  (:<*>:) :: SomeComb repr (a -> b) -> SomeComb repr a -> Comb Applicable repr b+  (:<*:) :: SomeComb repr a -> SomeComb repr b -> Comb Applicable repr a+  (:*>:) :: SomeComb repr a -> SomeComb repr b -> Comb Applicable repr b+infixl 4 :<*>:, :<*:, :*>:+pattern (:<$>:) :: TermGrammar (a -> b) -> SomeComb repr a -> Comb Applicable repr b+pattern t :<$>: x <- Comb (Pure t) :<*>: x+pattern (:$>:) :: SomeComb repr a -> TermGrammar b -> Comb Applicable repr b+pattern x :$>: t <- x :*>: Comb (Pure t)+instance Applicable repr => Trans (Comb Applicable repr) repr where+  trans = \case+    Pure x -> pure (H.optimizeTerm x)+    f :<*>: x -> trans f <*> trans x+    x :<*: y -> trans x <* trans y+    x :*>: y -> trans x *> trans y instance   ( Applicable repr   , Alternable repr-  , Selectable repr-  , Foldable repr   , Lookable repr   , Matchable repr-  , Letable TH.Name repr-  ) => Trans (Comb repr) repr where-  trans = \case-    Pure a -> pure a-    Satisfy es p -> satisfy es p-    Item -> item-    Try x -> try (trans x)-    Look x -> look (trans x)-    NegLook x -> negLook (trans x)-    Eof -> eof-    x :<*> y -> trans x <*> trans y-    x :<|> y -> trans x <|> trans y-    Empty -> empty-    Branch lr l r -> branch (trans lr) (trans l) (trans r)-    Match ps bs a b -> conditional ps (trans Functor.<$> bs) (trans a) (trans b)-    ChainPre x y -> chainPre (trans x) (trans y)-    ChainPost x y -> chainPost (trans x) (trans y)-    Def n x -> def n (trans x)-    Ref r n -> ref r n---- * Type 'OptimizeComb'--- Bottom-up application of 'optimizeCombNode'.-newtype OptimizeComb letName repr a =-        OptimizeComb { unOptimizeComb :: Comb repr a }+  , Selectable repr+  ) => Applicable (SomeComb repr) where+  pure = SomeComb . Pure+  f <$> Comb (Branch b l r) =+    branch b+      ((H..) H..@ f <$> l)+      ((H..) H..@ f <$> r)+    -- & trace "Branch Distributivity Law"+  f <$> Comb (Conditional a ps bs d) =+    conditional a ps+      ((f <$>) Functor.<$> bs)+      (f <$> d)+    -- & trace "Conditional Distributivity Law"+  -- Being careful here to use (<*>),+  -- instead of SomeComb (f <$> unOptComb x),+  -- in order to apply the optimizations of (<*>).+  f <$> x = pure f <*> x -optimizeComb ::-  Trans (OptimizeComb TH.Name repr) repr =>-  OptimizeComb TH.Name repr a -> repr a-optimizeComb = trans-instance-  Trans (Comb repr) repr =>-  Trans (OptimizeComb letName repr) repr where-  trans = trans . unOptimizeComb+  x <$ u = u $> x+    -- & trace "Commutativity Law" -type instance Output (OptimizeComb _letName repr) = Comb repr-instance Trans (OptimizeComb letName repr) (Comb repr) where-  trans = unOptimizeComb-instance Trans (Comb repr) (OptimizeComb letName repr) where-  trans = OptimizeComb . optimizeCombNode-instance Trans1 (Comb repr) (OptimizeComb letName repr)-instance Trans2 (Comb repr) (OptimizeComb letName repr)-instance Trans3 (Comb repr) (OptimizeComb letName repr)+  Comb Empty <*> _ = empty+    -- & trace "App Right Absorption Law"+  u <*> Comb Empty = u *> empty+    -- & trace "App Failure Weakening Law"+  Comb (Pure f) <*> Comb (Pure x) = pure (f H..@ x)+    -- & trace "Homomorphism Law"+  Comb (Pure f) <*> Comb (g :<$>: p) =+    -- This is basically a shortcut,+    -- it can be caught by the Composition Law+    -- and Homomorphism Law.+    (H..) H..@ f H..@ g <$> p+    -- & trace "Functor Composition Law"+  u <*> Comb (v :<*>: w) = (((H..) <$> u) <*> v) <*> w+    -- & trace "Composition Law"+  u <*> Comb (Pure x) = H.flip H..@ (H.$) H..@ x <$> u+    -- & trace "Interchange Law"+  Comb (u :*>: v) <*> w = u *> (v <*> w)+    -- & trace "Reassociation Law 1"+  u <*> Comb (v :<*: w) = (u <*> v) <* w+    -- & trace "Reassociation Law 2"+  u <*> Comb (v :$>: x) = (u <*> pure x) <* v+    -- & trace "Reassociation Law 3"+  p <*> Comb (NegLook q) =+    (p <*> pure H.unit) <* negLook (q)+    -- & trace "Absorption Law"+  x <*> y = SomeComb (x :<*>: y) -instance-  Letable letName (Comb repr) =>-  Letable letName (OptimizeComb letName repr) where-  -- Disable useless calls to 'optimizeCombNode'-  -- because 'Def' or 'Ref' have no matching in it.-  def n = OptimizeComb . def n . unOptimizeComb-  ref r n = OptimizeComb (ref r n)-instance Comb.Applicable (OptimizeComb letName repr)-instance Comb.Alternable (OptimizeComb letName repr)-instance Comb.Satisfiable repr tok =>-         Comb.Satisfiable (OptimizeComb letName repr) tok-instance Comb.Selectable (OptimizeComb letName repr)-instance Comb.Matchable (OptimizeComb letName repr)-instance Comb.Lookable (OptimizeComb letName repr)-instance Comb.Foldable (OptimizeComb letName repr)+  Comb Empty *> _ = empty+    -- & trace "App Right Absorption Law"+  Comb (_ :<$>: p) *> q = p *> q+    -- & trace "Right Absorption Law"+  Comb Pure{} *> u = u+    -- & trace "Identity Law"+  Comb (u :$>: _) *> v = u *> v+    -- & trace "Identity Law"+  u *> Comb (v :*>: w) = (u *> v) *> w+    -- & trace "Associativity Law"+  x *> y = SomeComb (x :*>: y) -optimizeCombNode :: Comb repr a -> Comb repr a-optimizeCombNode = \case-  -- Functor Identity Law-  H.Id :<$> x ->-    -- trace "Functor Identity Law" $-    x-  -- Functor Commutativity Law-  x :<$ u ->-    -- trace "Functor Commutativity Law" $-    optimizeCombNode (u :$> x)-  -- Functor Flip Const Law-  H.Flip H.:@ H.Const :<$> u ->-    -- trace "Functor Flip Const Law" $-    optimizeCombNode (u :*> Pure H.Id)-  -- Functor Homomorphism Law-  f :<$> Pure x ->-    -- trace "Functor Homomorphism Law" $-    Pure (f H..@ x)+  Comb Empty <* _ = empty+    -- & trace "App Right Absorption Law"+  u <* Comb Empty = u *> empty+    -- & trace "App Failure Weakening Law"+  p <* Comb (_ :<$>: q) = p <* q+    -- & trace "Left Absorption Law"+  u <* Comb Pure{} = u+    -- & trace "Identity Law"+  u <* Comb (v :$>: _) = u <* v+    -- & trace "Identity Law"+  Comb (u :<*: v) <* w = u <* (v <* w)+    -- & trace "Associativity Law"+  x <* y = SomeComb (x :<*: y) -  -- App Right Absorption Law-  Empty :<*> _ ->-    -- trace "App Right Absorption Law" $-    Empty-  _ :<*> Empty ->-    -- In Parsley: this is only a weakening to u :*> Empty-    -- but here :*> is an alias to :<*>-    -- hence it would loop on itself forever.-    -- trace "App Left Absorption Law" $-    Empty-  -- App Composition Law-  u :<*> (v :<*> w) ->-    -- trace "App Composition Law" $-    optimizeCombNode (optimizeCombNode (optimizeCombNode ((H.:.) :<$> u) :<*> v) :<*> w)-  -- App Interchange Law-  u :<*> Pure x ->-    -- trace "App Interchange Law" $-    optimizeCombNode (H.Flip H..@ (H.:$) H..@ x :<$> u)-  -- App Left Absorption Law-  p :<* (_ :<$> q) ->-    -- trace "App Left Absorption Law" $-    p :<* q-  -- App Right Absorption Law-  (_ :<$> p) :*> q ->-    -- trace "App Right Absorption Law" $-    p :*> q-  -- App Pure Left Identity Law-  Pure _ :*> u ->-    -- trace "App Pure Left Identity Law" $-    u-  -- App Functor Left Identity Law-  (u :$> _) :*> v ->-    -- trace "App Functor Left Identity Law" $-    u :*> v-  -- App Pure Right Identity Law-  u :<* Pure _ ->-    -- trace "App Pure Right Identity Law" $-    u-  -- App Functor Right Identity Law-  u :<* (v :$> _) ->-    -- trace "App Functor Right Identity Law" $-    optimizeCombNode (u :<* v)-  -- App Left Associativity Law-  (u :<* v) :<* w ->-    -- trace "App Left Associativity Law" $-    optimizeCombNode (u :<* optimizeCombNode (v :<* w))+-- Alternable+data instance Comb Alternable repr a where+  Empty :: Comb Alternable repr a+  (:<|>:) :: SomeComb repr a -> SomeComb repr a -> Comb Alternable repr a+  Try :: SomeComb repr a -> Comb Alternable repr a+infixl 3 :<|>:+instance Alternable repr => Trans (Comb Alternable repr) repr where+  trans = \case+    Empty -> empty+    f :<|>: x -> trans f <|> trans x+    Try x -> try (trans x)+instance+  ( Alternable repr+  , Applicable repr+  , Lookable repr+  , Matchable repr+  , Selectable repr+  ) => Alternable (SomeComb repr) where+  empty = SomeComb Empty -  -- Alt Left CatchFail Law-  p@Pure{} :<|> _ ->-    -- trace "Alt Left CatchFail Law" $-    p-  -- Alt Left Neutral Law-  Empty :<|> u ->-    -- trace "Alt Left Neutral Law" $-    u-  -- All Right Neutral Law-  u :<|> Empty ->-    -- trace "Alt Right Neutral Law" $-    u-  -- Alt Associativity Law-  (u :<|> v) :<|> w ->-    -- trace "Alt Associativity Law" $-    u :<|> optimizeCombNode (v :<|> w)+  p@(Comb Pure{}) <|> _ = p+    -- & trace "Left Catch Law"+  Comb Empty <|> u = u+    -- & trace "Left Neutral Law"+  u <|> Comb Empty = u+    -- & trace "Right Neutral Law"+  Comb (u :<|>: v) <|> w = u <|> (v <|> w)+    -- & trace "Associativity Law"+  Comb (Look p) <|> Comb (Look q) = look (try p <|> q)+    -- & trace "Distributivity Law"+  x <|> y = SomeComb (x :<|>: y) -  -- Look Pure Law-  Look p@Pure{} ->-    -- trace "Look Pure Law" $-    p-  -- Look Empty Law-  Look p@Empty ->-    -- trace "Look Empty Law" $-    p-  -- NegLook Pure Law-  NegLook Pure{} ->-    -- trace "NegLook Pure Law" $-    Empty-  -- NegLook Empty Law-  NegLook Empty ->-    -- trace "NegLook Dead Law" $-    Pure H.unit-  -- NegLook Double Negation Law-  NegLook (NegLook p) ->-    -- trace "NegLook Double Negation Law" $-    optimizeCombNode (Look (Try p) :*> Pure H.unit)-  -- NegLook Zero Consumption Law-  NegLook (Try p) ->-    -- trace "NegLook Zero Consumption Law" $-    optimizeCombNode (NegLook p)-  -- Idempotence Law-  Look (Look p) ->-    -- trace "Look Idempotence Law" $-    Look p-  -- Look Right Identity Law-  NegLook (Look p) ->-    -- trace "Look Right Identity Law" $-    optimizeCombNode (NegLook p)-  -- Look Left Identity Law-  Look (NegLook p) ->-    -- trace "Look Left Identity Law" $-    NegLook p-  -- NegLook Transparency Law-  NegLook (Try p :<|> q) ->-    -- trace "NegLook Transparency Law" $-    optimizeCombNode (optimizeCombNode (NegLook p) :*> optimizeCombNode (NegLook q))-  -- Look Distributivity Law-  Look p :<|> Look q ->-    -- trace "Look Distributivity Law" $-    optimizeCombNode (Look (optimizeCombNode (Try p :<|> q)))-  -- Look Interchange Law-  Look (f :<$> p) ->-    -- trace "Look Interchange Law" $-    optimizeCombNode (f :<$> optimizeCombNode (Look p))-  -- NegLook Idempotence Right Law-  NegLook (_ :<$> p) ->-    -- trace "NegLook Idempotence Law" $-    optimizeCombNode (NegLook p)-  -- Try Interchange Law-  Try (f :<$> p) ->-    -- trace "Try Interchange Law" $-    optimizeCombNode (f :<$> optimizeCombNode (Try p))+  try (Comb (p :$>: x)) = try p $> x+    -- & trace "Try Interchange Law"+  try (Comb (f :<$>: p)) = f <$> try p+    -- & trace "Try Interchange Law"+  try x = SomeComb (Try x) -  -- Branch Absorption Law-  Branch Empty _ _ ->-    -- trace "Branch Absorption Law" $-    empty-  -- Branch Weakening Law-  Branch b Empty Empty ->-    -- trace "Branch Weakening Law" $-    optimizeCombNode (b :*> Empty)-  -- Branch Pure Left/Right Laws-  Branch (Pure (trans -> lr)) l r ->-    -- trace "Branch Pure Left/Right Law" $-    case getValue lr of-     Left v -> optimizeCombNode (l :<*> Pure (H.Haskell (ValueCode (Value v) c)))-      where c = [|| case $$(code lr) of Left x -> x ||]-     Right v -> optimizeCombNode (r :<*> Pure (H.Haskell (ValueCode (Value v) c)))-      where c = [|| case $$(code lr) of Right x -> x ||]-  -- Branch Generalised Identity Law-  Branch b (Pure (trans -> l)) (Pure (trans -> r)) ->-    -- trace "Branch Generalised Identity Law" $-    optimizeCombNode (H.Haskell (ValueCode v c) :<$> b)+-- Selectable+data instance Comb Selectable repr a where+  Branch ::+    SomeComb repr (Either a b) ->+    SomeComb repr (a -> c) ->+    SomeComb repr (b -> c) ->+    Comb Selectable repr c+instance Selectable repr => Trans (Comb Selectable repr) repr where+  trans = \case+    Branch lr l r -> branch (trans lr) (trans l) (trans r)+instance+  ( Applicable repr+  , Alternable repr+  , Lookable repr+  , Selectable repr+  , Matchable repr+  ) => Selectable (SomeComb repr) where+  branch (Comb Empty) _ _ = empty+    -- & trace "Branch Absorption Law"+  branch b (Comb Empty) (Comb Empty) = b *> empty+    -- & trace "Branch Weakening Law"+  branch (Comb (Pure (trans -> lr))) l r =+    case H.value lr of+      Left value -> l <*> pure (trans H.ValueCode{..})+        where code = [|| case $$(H.code lr) of Left x -> x ||]+      Right value -> r <*> pure (trans H.ValueCode{..})+        where code = [|| case $$(H.code lr) of Right x -> x ||]+    -- & trace "Branch Pure Left/Right Law" $+  branch b (Comb (Pure (trans -> l))) (Comb (Pure (trans -> r))) =+    trans H.ValueCode{..} <$> b+    -- & trace "Branch Generalised Identity Law"     where-    v = Value (either (getValue l) (getValue r))-    c = [|| either $$(code l) $$(code r) ||]-  -- Branch Interchange Law-  Branch (x :*> y) p q ->-    -- trace "Branch Interchange Law" $-    optimizeCombNode (x :*> optimizeCombNode (Branch y p q))-  -- Branch Empty Right Law-  Branch b l Empty ->-    -- trace " Branch Empty Right Law" $-    Branch (Pure (H.Haskell (ValueCode v c)) :<*> b) Empty l+    value = either (H.value l) (H.value r)+    code = [|| either $$(H.code l) $$(H.code r) ||]+  branch (Comb (x :*>: y)) p q = x *> branch y p q+    -- & trace "Interchange Law"+  branch b l (Comb Empty) =+    branch (pure (trans (H.ValueCode{..})) <*> b) empty l+    -- & trace "Negated Branch Law"     where-    v = Value (either Right Left)-    c = [||either Right Left||]-  -- Branch Fusion Law-  Branch (Branch b Empty (Pure (trans -> lr))) Empty br ->-    -- trace "Branch Fusion Law" $-    optimizeCombNode (Branch (optimizeCombNode (Pure (H.Haskell (ValueCode (Value v) c)) :<*> b))-                             Empty br)+    value = either Right Left+    code = [||either Right Left||]+  branch (Comb (Branch b (Comb Empty) (Comb (Pure (trans -> lr))))) (Comb Empty) br =+    branch (pure (trans H.ValueCode{..}) <*> b) empty br+    -- & trace "Branch Fusion Law"     where-    v Left{} = Left ()-    v (Right r) = case getValue lr r of-                   Left _ -> Left ()-                   Right rr -> Right rr-    c = [|| \case Left{} -> Left ()-                  Right r -> case $$(code lr) r of-                              Left _ -> Left ()-                              Right rr -> Right rr ||]-  -- Branch Distributivity Law-  f :<$> Branch b l r ->-    -- trace "Branch Distributivity Law" $-    optimizeCombNode (Branch b (optimizeCombNode ((H..@) (H..) f :<$> l))-                               (optimizeCombNode ((H..@) (H..) f :<$> r)))+    value Left{} = Left ()+    value (Right r) = case H.value lr r of+                        Left _ -> Left ()+                        Right rr -> Right rr+    code = [|| \case Left{} -> Left ()+                     Right r -> case $$(H.code lr) r of+                                  Left _ -> Left ()+                                  Right rr -> Right rr ||]+  branch b l r = SomeComb (Branch b l r) -  -- Match Absorption Law-  Match _ _ Empty d ->-    -- trace "Match Absorption Law" $-    d-  -- Match Weakening Law-  Match _ bs a Empty-    | all (\case {Empty -> True; _ -> False}) bs ->-      -- trace "Match Weakening Law" $-      optimizeCombNode (a :*> Empty)-  -- Match Pure Law-  Match ps bs (Pure (trans -> a)) d ->-    -- trace "Match Pure Law" $-    foldr (\(trans -> p, b) next ->-      if getValue p (getValue a) then b else next+-- Matchable+data instance Comb Matchable repr a where+  Conditional :: Eq a =>+    SomeComb repr a ->+    [TermGrammar (a -> Bool)] ->+    [SomeComb repr b] ->+    SomeComb repr b ->+    Comb Matchable repr b+instance Matchable repr => Trans (Comb Matchable repr) repr where+  trans = \case+    Conditional a ps bs b -> conditional (trans a) ps (trans Functor.<$> bs) (trans b)+instance+  ( Applicable repr+  , Alternable repr+  , Lookable repr+  , Selectable repr+  , Matchable repr+  ) => Matchable (SomeComb repr) where+  conditional (Comb Empty) _ _ d = d+    -- & trace "Conditional Absorption Law"+  conditional p _ qs (Comb Empty)+    | Foldable.all (\case { Comb Empty -> True; _ -> False }) qs = p *> empty+      -- & trace "Conditional Weakening Law"+  conditional a _ps bs (Comb Empty)+    | Foldable.all (\case { Comb Empty -> True; _ -> False }) bs = a *> empty+      -- & trace "Conditional Weakening Law"+  conditional (Comb (Pure (trans -> a))) ps bs d =+    Foldable.foldr (\(trans -> p, b) next ->+      if H.value p (H.value a) then b else next     ) d (List.zip ps bs)-  -- Match Distributivity Law-  f :<$> Match ps bs a d ->-    -- trace "Match Distributivity Law" $-    Match ps (optimizeCombNode . (f :<$>) Functor.<$> bs) a-             (optimizeCombNode (f :<$> d))+    -- & trace "Conditional Pure Law"+  conditional a ps bs d = SomeComb (Conditional a ps bs d) -  {- Possibly useless laws to be tested-  Empty  :*> _ -> Empty-  Empty :<*  _ -> Empty-  -- App Definition of *> Law-  H.Flip H..@ H.Const :<$> p :<*> q ->-    -- -- trace "EXTRALAW: App Definition of *> Law" $-    p :*> q-  -- App Definition of <* Law-  H.Const :<$> p :<*> q ->-    -- -- trace "EXTRALAW: App Definition of <* Law" $-    p :<* q+-- Foldable+data instance Comb Foldable repr a where+  ChainPreC :: SomeComb repr (a -> a) -> SomeComb repr a -> Comb Foldable repr a+  ChainPostC :: SomeComb repr a -> SomeComb repr (a -> a) -> Comb Foldable repr a+instance Foldable repr => Trans (Comb Foldable repr) repr where+  trans = \case+    ChainPreC x y -> chainPre (trans x) (trans y)+    ChainPostC x y -> chainPost (trans x) (trans y)+instance Foldable repr => Foldable (SomeComb repr) where+  chainPre x = SomeComb . ChainPreC x+  chainPost x = SomeComb . ChainPostC x -  -- Functor Composition Law-  -- (a shortcut that could also have been be caught-  -- by the Composition Law and Homomorphism Law)-  f :<$> (g :<$> p) ->-    -- -- trace "EXTRALAW: Functor Composition Law" $-    optimizeCombNode ((H.:.) H..@ f H..@ g :<$> p)-  -- Applicable Failure Weakening Law-  u :<*  Empty ->-    -- -- trace "EXTRALAW: App Failure Weakening Law" $-    optimizeCombNode (u :*> Empty)-  Try (p :$> x) ->-    -- -- trace "EXTRALAW: Try Interchange Right Law" $-    optimizeCombNode (optimizeCombNode (Try p) :$> x)-  -- App Reassociation Law 1-  (u :*> v) :<*> w ->-    -- -- trace "EXTRALAW: App Reassociation Law 1" $-    optimizeCombNode (u :*> optimizeCombNode (v :<*> w))-  -- App Reassociation Law 2-  u :<*> (v :<* w) ->-    -- -- trace "EXTRALAW: App Reassociation Law 2" $-    optimizeCombNode (optimizeCombNode (u :<*> v) :<* w)-  -- App Right Associativity Law-  u :*> (v :*> w) ->-    -- -- trace "EXTRALAW: App Right Associativity Law" $-    optimizeCombNode (optimizeCombNode (u :*> v) :*> w)-  -- App Reassociation Law 3-  u :<*> (v :$> x) ->-    -- -- trace "EXTRALAW: App Reassociation Law 3" $-    optimizeCombNode (optimizeCombNode (u :<*> Pure x) :<* v)+-- Lookable+data instance Comb Lookable repr a where+  Look :: SomeComb repr a -> Comb Lookable repr a+  NegLook :: SomeComb repr a -> Comb Lookable repr ()+  Eof :: Comb Lookable repr ()+instance Lookable repr => Trans (Comb Lookable repr) repr where+  trans = \case+    Look x -> look (trans x)+    NegLook x -> negLook (trans x)+    Eof -> eof+instance+  ( Alternable repr+  , Applicable repr+  , Lookable repr+  , Selectable repr+  , Matchable repr+  ) => Lookable (SomeComb repr) where+  look p@(Comb Pure{}) = p+    -- & trace "Pure Look Law"+  look p@(Comb Empty) = p+    -- & trace "Dead Look Law"+  look (Comb (Look x)) = look x+    -- & trace "Idempotence Law"+  look (Comb (NegLook x)) = negLook x+    -- & trace "Left Identity Law"+  look (Comb (p :$>: x)) = look p $> x+    -- & trace "Interchange Law"+  look (Comb (f :<$>: p)) = f <$> look p+    -- & trace "Interchange Law"+  look x = SomeComb (Look x) -  Look (p :$> x) ->-    optimizeCombNode (optimizeCombNode (Look p) :$> x)-  NegLook (p :$> _) -> optimizeCombNode (NegLook p)+  negLook (Comb Pure{}) = empty+    -- & trace "Pure Negative-Look"+  negLook (Comb Empty) = pure H.unit+    -- & trace "Dead Negative-Look"+  negLook (Comb (NegLook x)) = look (try x *> pure H.unit)+    -- & trace "Double Negation Law"+  negLook (Comb (Try x)) = negLook x+    -- & trace "Zero Consumption Law"+  negLook (Comb (Look x)) = negLook x+    -- & trace "Right Identity Law"+  negLook (Comb (Comb (Try p) :<|>: q)) = negLook p *> negLook q+    -- & trace "Transparency Law"+  negLook (Comb (p :$>: _)) = negLook p+    -- & trace "NegLook Idempotence Law"+  negLook x = SomeComb (NegLook x) -  -- NegLook Absorption Law-  p :<*> NegLook q ->-    -- trace "EXTRALAW: Neglook Absorption Law" $-    optimizeCombNode (optimizeCombNode (p :<*> Pure H.unit) :<* NegLook q)-    -- Infinite loop, because :<* expands to :<*>-  -}+  eof = SomeComb Eof -  x -> x+-- Satisfiable+data instance Comb (Satisfiable tok) repr a where+  Satisfy ::+    Satisfiable tok repr =>+    [ErrorItem tok] ->+    TermGrammar (tok -> Bool) ->+    Comb (Satisfiable tok) repr tok+  Item ::+    Satisfiable tok repr =>+    Comb (Satisfiable tok) repr tok+instance Satisfiable tok repr => Trans (Comb (Satisfiable tok) repr) repr where+  trans = \case+    Satisfy es p -> satisfy es p+    Item -> item+instance+  (Satisfiable tok repr, Typeable tok) =>+  Satisfiable tok (SomeComb repr) where+  satisfy es = SomeComb . Satisfy es+  item = SomeComb Item++-- Letable+data instance Comb (Letable letName) repr a where+  Def :: letName -> SomeComb repr a -> Comb (Letable letName) repr a+  Ref :: Bool -> letName -> Comb (Letable letName) repr a+instance Letable letName repr => Trans (Comb (Letable letName) repr) repr where+  trans = \case+    Def n v -> def n (trans v)+    Ref isRec n -> ref isRec n+instance+  (Letable letName repr, Typeable letName) =>+  Letable letName (SomeComb repr) where+  def n = SomeComb . Def n+  ref isRec = SomeComb . Ref isRec+instance MakeLetName TH.Name where+  makeLetName _ = TH.qNewName "name"

@@ -0,0 +1,74 @@+module Symantic.Parser.Grammar.View where++import Data.Bool (Bool)+import Data.Function (($), (.), id)+import Data.Semigroup (Semigroup(..))+import Data.String (String, IsString(..))+import Text.Show (Show(..))+import qualified Control.Applicative as Fct+import qualified Data.Tree as Tree+import qualified Data.List as List++import Symantic.Univariant.Letable+import Symantic.Parser.Grammar.Combinators++-- * Type 'ViewGrammar'+newtype ViewGrammar (showName::Bool) a = ViewGrammar { unViewGrammar ::+  Tree.Tree String }++viewGrammar :: ViewGrammar sN a -> ViewGrammar sN a+viewGrammar = id++instance Show (ViewGrammar sN a) where+  show = drawTree . unViewGrammar+    where+    drawTree :: Tree.Tree String -> String+    drawTree  = List.unlines . draw+    draw :: Tree.Tree String -> [String]+    draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0+      where+      drawSubTrees [] = []+      drawSubTrees [t] = shift "` " "  " (draw t)+      drawSubTrees (t:ts) = shift "+ " "| " (draw t) <> drawSubTrees ts+      shift first other = List.zipWith (<>) (first : List.repeat other)+instance IsString (ViewGrammar sN a) where+  fromString s = ViewGrammar $ Tree.Node (fromString s) []++instance+  ShowLetName sN letName =>+  Letable letName (ViewGrammar sN) where+  def name x = ViewGrammar $+    Tree.Node ("def "<>showLetName @sN name) [unViewGrammar x]+  ref rec name = ViewGrammar $+    Tree.Node+      ( (if rec then "rec " else "ref ")+      <> showLetName @sN name+      ) []+instance Applicable (ViewGrammar sN) where+  _f <$> x = ViewGrammar $ Tree.Node "<$>" [unViewGrammar x]+  pure a = ViewGrammar $ Tree.Node ("pure "<>showsPrec 10 a "") []+  x <*> y = ViewGrammar $ Tree.Node "<*>" [unViewGrammar x, unViewGrammar y]+  x <* y = ViewGrammar $ Tree.Node "<*" [unViewGrammar x, unViewGrammar y]+  x *> y = ViewGrammar $ Tree.Node "*>" [unViewGrammar x, unViewGrammar y]+instance Alternable (ViewGrammar sN) where+  empty = ViewGrammar $ Tree.Node "empty" []+  x <|> y = ViewGrammar $ Tree.Node "<|>" [unViewGrammar x, unViewGrammar y]+  try x = ViewGrammar $ Tree.Node "try" [unViewGrammar x]+instance Satisfiable tok (ViewGrammar sN) where+  satisfy _es _p = ViewGrammar $ Tree.Node "satisfy" []+instance Selectable (ViewGrammar sN) where+  branch lr l r = ViewGrammar $ Tree.Node "branch"+    [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]+instance Matchable (ViewGrammar sN) where+  conditional a _ps bs b = ViewGrammar $ Tree.Node "conditional"+    [ unViewGrammar a+    , Tree.Node "bs" (unViewGrammar Fct.<$> bs)+    , unViewGrammar b+    ]+instance Lookable (ViewGrammar sN) where+  look x = ViewGrammar $ Tree.Node "look" [unViewGrammar x]+  negLook x = ViewGrammar $ Tree.Node "negLook" [unViewGrammar x]+  eof = ViewGrammar $ Tree.Node "eof" []+instance Foldable (ViewGrammar sN) where+  chainPre f x = ViewGrammar $ Tree.Node "chainPre" [unViewGrammar f, unViewGrammar x]+  chainPost x f = ViewGrammar $ Tree.Node "chainPost" [unViewGrammar x, unViewGrammar f]

@@ -1,13 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} module Symantic.Parser.Grammar.Write where +import Data.Bool (Bool(..)) import Control.Monad (Monad(..)) import Data.Function (($)) import Data.Maybe (Maybe(..), fromMaybe, catMaybes) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.String (IsString(..))-import Text.Show (Show(..)) import qualified Data.Functor as Pre import qualified Data.List as List import qualified Data.Text.Lazy as TL@@ -17,62 +17,64 @@ import Symantic.Parser.Grammar.Combinators import Symantic.Parser.Grammar.Fixity --- * Type 'WriteComb'-newtype WriteComb a = WriteComb { unWriteComb :: WriteCombInh -> Maybe TLB.Builder }+-- * Type 'WriteGrammar'+newtype WriteGrammar (showName::Bool) a = WriteGrammar { unWriteGrammar :: WriteGrammarInh -> Maybe TLB.Builder } -instance IsString (WriteComb a) where-  fromString s = WriteComb $ \_inh ->+instance IsString (WriteGrammar sN a) where+  fromString s = WriteGrammar $ \_inh ->     if List.null s then Nothing     else Just (fromString s) --- ** Type 'WriteCombInh'-data WriteCombInh- =   WriteCombInh- {   writeCombInh_indent :: TLB.Builder- ,   writeCombInh_op :: (Infix, Side)- ,   writeCombInh_pair :: Pair+-- ** Type 'WriteGrammarInh'+data WriteGrammarInh+ =   WriteGrammarInh+ {   writeGrammarInh_indent :: TLB.Builder+ ,   writeGrammarInh_op :: (Infix, Side)+ ,   writeGrammarInh_pair :: Pair  } -emptyWriteCombInh :: WriteCombInh-emptyWriteCombInh = WriteCombInh- { writeCombInh_indent = "\n"- , writeCombInh_op = (infixN0, SideL)- , writeCombInh_pair = pairParen+emptyWriteGrammarInh :: WriteGrammarInh+emptyWriteGrammarInh = WriteGrammarInh+ { writeGrammarInh_indent = "\n"+ , writeGrammarInh_op = (infixN0, SideL)+ , writeGrammarInh_pair = pairParen  } -writeComb :: WriteComb a -> TL.Text-writeComb (WriteComb r) = TLB.toLazyText $ fromMaybe "" $ r emptyWriteCombInh+writeGrammar :: WriteGrammar sN a -> TL.Text+writeGrammar (WriteGrammar r) = TLB.toLazyText $ fromMaybe "" $ r emptyWriteGrammarInh -pairWriteCombInh ::+pairWriteGrammarInh ::  Semigroup s => IsString s =>- WriteCombInh -> Infix -> Maybe s -> Maybe s-pairWriteCombInh inh op s =-  if isPairNeeded (writeCombInh_op inh) op+ WriteGrammarInh -> Infix -> Maybe s -> Maybe s+pairWriteGrammarInh inh op s =+  if isPairNeeded (writeGrammarInh_op inh) op   then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)   else s-  where (o,c) = writeCombInh_pair inh+  where (o,c) = writeGrammarInh_pair inh -instance Show letName => Letable letName WriteComb where-  def name x = WriteComb $ \inh ->-    pairWriteCombInh inh op $+instance+  ShowLetName sN letName =>+  Letable letName (WriteGrammar sN) where+  def name x = WriteGrammar $ \inh ->+    pairWriteGrammarInh inh op $       Just "def "-      <> Just (fromString (show name))-      <> unWriteComb x inh+      <> Just (fromString (showLetName @sN name))+      <> unWriteGrammar x inh     where     op = infixN 9-  ref rec name = WriteComb $ \inh ->-    pairWriteCombInh inh op $+  ref rec name = WriteGrammar $ \inh ->+    pairWriteGrammarInh inh op $       Just (if rec then "rec " else "ref ") <>-      Just (fromString (show name))+      Just (fromString (showLetName @sN name))     where     op = infixN 9-instance Applicable WriteComb where-  pure _ = WriteComb $ return Nothing+instance Applicable (WriteGrammar sN) where+  pure _ = WriteGrammar $ return Nothing   -- pure _ = "pure"-  WriteComb x <*> WriteComb y = WriteComb $ \inh ->+  WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->     let inh' side = inh-         { writeCombInh_op = (op, side)-         , writeCombInh_pair = pairParen+         { writeGrammarInh_op = (op, side)+         , writeGrammarInh_pair = pairParen          } in     case x (inh' SideL) of      Nothing -> y (inh' SideR)@@ -80,73 +82,73 @@       case y (inh' SideR) of        Nothing -> Just xt        Just yt ->-        pairWriteCombInh inh op $+        pairWriteGrammarInh inh op $           Just $ xt <> ", " <> yt     where     op = infixN 1-instance Alternable WriteComb where+instance Alternable (WriteGrammar sN) where   empty = "empty"-  try x = WriteComb $ \inh ->-    pairWriteCombInh inh op $-      Just "try " <> unWriteComb x inh+  try x = WriteGrammar $ \inh ->+    pairWriteGrammarInh inh op $+      Just "try " <> unWriteGrammar x inh     where     op = infixN 9-  x <|> y = WriteComb $ \inh ->-    pairWriteCombInh inh op $-    unWriteComb x inh-     { writeCombInh_op = (op, SideL)-     , writeCombInh_pair = pairParen+  x <|> y = WriteGrammar $ \inh ->+    pairWriteGrammarInh inh op $+    unWriteGrammar x inh+     { writeGrammarInh_op = (op, SideL)+     , writeGrammarInh_pair = pairParen      } <>     Just " | " <>-    unWriteComb y inh-     { writeCombInh_op = (op, SideR)-     , writeCombInh_pair = pairParen+    unWriteGrammar y inh+     { writeGrammarInh_op = (op, SideR)+     , writeGrammarInh_pair = pairParen      }     where op = infixB SideL 3-instance Satisfiable WriteComb tok where+instance Satisfiable tok (WriteGrammar sN) where   satisfy _es _f = "satisfy"-instance Selectable WriteComb where-  branch lr l r = WriteComb $ \inh ->-    pairWriteCombInh inh op $+instance Selectable (WriteGrammar sN) where+  branch lr l r = WriteGrammar $ \inh ->+    pairWriteGrammarInh inh op $       Just "branch " <>-      unWriteComb lr inh <> Just " " <>-      unWriteComb l inh <> Just " " <>-      unWriteComb r inh+      unWriteGrammar lr inh <> Just " " <>+      unWriteGrammar l inh <> Just " " <>+      unWriteGrammar r inh     where     op = infixN 9-instance Matchable WriteComb where-  conditional _ps bs a d = WriteComb $ \inh ->-    pairWriteCombInh inh op $+instance Matchable (WriteGrammar sN) where+  conditional a _ps bs d = WriteGrammar $ \inh ->+    pairWriteGrammarInh inh op $       Just "conditional " <>-      Just "[" <>+      unWriteGrammar a inh <>+      Just " [" <>       Just (mconcat (List.intersperse ", " $       catMaybes $ (Pre.<$> bs) $ \x ->-        unWriteComb x inh{writeCombInh_op=(infixN 0, SideL)})) <>+        unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>       Just "] " <>-      unWriteComb a inh <> Just " " <>-      unWriteComb d inh+      unWriteGrammar d inh     where     op = infixN 9-instance Lookable WriteComb where-  look x = WriteComb $ \inh ->-    pairWriteCombInh inh op $-      Just "look " <> unWriteComb x inh+instance Lookable (WriteGrammar sN) where+  look x = WriteGrammar $ \inh ->+    pairWriteGrammarInh inh op $+      Just "look " <> unWriteGrammar x inh     where op = infixN 9-  negLook x = WriteComb $ \inh ->-    pairWriteCombInh inh op $-      Just "negLook " <> unWriteComb x inh+  negLook x = WriteGrammar $ \inh ->+    pairWriteGrammarInh inh op $+      Just "negLook " <> unWriteGrammar x inh     where op = infixN 9   eof = "eof"-instance Foldable WriteComb where-  chainPre f x = WriteComb $ \inh ->-    pairWriteCombInh inh op $+instance Foldable (WriteGrammar sN) where+  chainPre f x = WriteGrammar $ \inh ->+    pairWriteGrammarInh inh op $       Just "chainPre " <>-      unWriteComb f inh <> Just " " <>-      unWriteComb x inh+      unWriteGrammar f inh <> Just " " <>+      unWriteGrammar x inh     where op = infixN 9-  chainPost f x = WriteComb $ \inh ->-    pairWriteCombInh inh op $+  chainPost f x = WriteGrammar $ \inh ->+    pairWriteGrammarInh inh op $       Just "chainPost " <>-      unWriteComb f inh <> Just " " <>-      unWriteComb x inh+      unWriteGrammar f inh <> Just " " <>+      unWriteGrammar x inh     where op = infixN 9

@@ -1,215 +1,8 @@-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TemplateHaskell #-}--- | Haskell terms which are interesting--- to pattern-match when optimizing.-module Symantic.Parser.Haskell where--import Data.Bool (Bool(..))-import Data.Either (Either(..))-import Data.Eq (Eq)-import Data.Maybe (Maybe(..))-import Data.Ord (Ord(..))-import Data.Kind (Type)-import Text.Show (Show(..), showParen, showString)-import qualified Data.Eq as Eq-import qualified Data.Function as Function-import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Syntax as TH--import Symantic.Univariant.Trans---- * Type 'ValueCode'--- | Compile-time 'value' and corresponding 'code'--- (that can produce that value at runtime).-data ValueCode a = ValueCode-  { value :: Value a-  , code :: TH.CodeQ a-  }-getValue :: ValueCode a -> a-getValue = unValue Function.. value-getCode :: ValueCode a -> TH.CodeQ a-getCode = code---- ** Type 'Value'-newtype Value a = Value { unValue :: a }---- * Class 'Haskellable'--- | Final encoding of some Haskell functions--- useful for some optimizations in 'optimizeComb'.-class Haskellable (repr :: Type -> Type) where-  (.) :: repr ((b->c) -> (a->b) -> a -> c)-  ($) :: repr ((a->b) -> a -> b)-  (.@) :: repr (a->b) -> repr a -> repr b-  bool :: Bool -> repr Bool-  char :: TH.Lift tok => tok -> repr tok-  cons :: repr (a -> [a] -> [a])-  const :: repr (a -> b -> a)-  eq :: Eq a => repr a -> repr (a -> Bool)-  flip :: repr ((a -> b -> c) -> b -> a -> c)-  id :: repr (a->a)-  nil :: repr [a]-  unit :: repr ()-  left :: repr (l -> Either l r)-  right :: repr (r -> Either l r)-  nothing :: repr (Maybe a)-  just :: repr (a -> Maybe a)---- ** Type 'Haskellable'--- | Initial encoding of 'Haskellable'.-data Haskell a where-  Haskell :: ValueCode a -> Haskell a-  (:.) :: Haskell ((b->c) -> (a->b) -> a -> c)-  (:$) :: Haskell ((a->b) -> a -> b)-  (:@) :: Haskell (a->b) -> Haskell a -> Haskell b-  Cons :: Haskell (a -> [a] -> [a])-  Const :: Haskell (a -> b -> a)-  Eq :: Eq a => Haskell a -> Haskell (a -> Bool)-  Flip :: Haskell ((a -> b -> c) -> b -> a -> c)-  Id :: Haskell (a->a)-  Unit :: Haskell ()-infixr 0 $, :$-infixr 9 ., :.-infixl 9 .@, :@--{--pattern (:.@) ::-  -- Dummy constraint to get the following constraint-  -- in scope when pattern-matching.-  () =>-  ((x -> y -> z) ~ ((b -> c) -> (a -> b) -> a -> c)) =>-  Haskell x -> Haskell y -> Haskell z-pattern (:.@) f g = (:.) :@ f :@ g-pattern FlipApp ::-  () =>-  ((x -> y) ~ ((a -> b -> c) -> b -> a -> c)) =>-  Haskell x -> Haskell y-pattern FlipApp f = Flip :@ f-pattern FlipConst ::-  () =>-  (x ~ (a -> b -> b)) =>-  Haskell x-pattern FlipConst = FlipApp Const--}--instance Show (Haskell a) where-  showsPrec p = \case-    Haskell{} -> showString "Haskell"-    (:$) -> showString "($)"-    (:.) :@ f :@ g ->-      showParen (p >= 9)-      Function.$ showsPrec 9 f-      Function.. showString " . "-      Function.. showsPrec 9 g-    (:.) -> showString "(.)"-    Cons :@ x :@ xs ->-      showParen (p >= 10)-      Function.$ showsPrec 10 x-      Function.. showString " : "-      Function.. showsPrec 10 xs-    Cons -> showString "cons"-    Const -> showString "const"-    Eq x ->-      showParen True-      Function.$ showString "== "-      Function.. showsPrec 0 x-    Flip -> showString "flip"-    Id -> showString "id"-    Unit -> showString "()"-    (:@) f x ->-      showParen (p >= 10)-      Function.$ showsPrec 10 f-      Function.. showString " "-      Function.. showsPrec 10 x-instance Trans Haskell Value where-  trans = value Function.. trans-instance Trans Haskell TH.CodeQ where-  trans = code Function.. trans-instance Trans Haskell ValueCode where-  trans = \case-    Haskell x -> x-    (:.) -> (.)-    (:$) -> ($)-    (:@) f x -> (.@) (trans f) (trans x)-    Cons -> cons-    Const -> const-    Eq x -> eq (trans x)-    Flip -> flip-    Id -> id-    Unit -> unit-instance Trans ValueCode Haskell where-  trans = Haskell-type instance Output Haskell = ValueCode--instance Haskellable Haskell where-  (.)     = (:.)-  ($)     = (:$)-  -- Small optimizations, mainly to reduce dump sizes.-  Id .@ x = x-  (Const :@ x) .@ _y = x-  ((Flip :@ Const) :@ _x) .@ y = y-  ---  f .@ x  = f :@ x-  cons    = Cons-  const   = Const-  eq      = Eq-  flip    = Flip-  id      = Id-  unit    = Unit-  bool b  = Haskell (bool b)-  char c  = Haskell (char c)-  nil     = Haskell nil-  left    = Haskell left-  right   = Haskell right-  nothing = Haskell nothing-  just    = Haskell just-instance Haskellable ValueCode where-  (.)      = ValueCode (.) (.)-  ($)      = ValueCode ($) ($)-  (.@) f x = ValueCode ((.@) (value f) (value x)) ((.@) (code f) (code x))-  bool b   = ValueCode (bool b) (bool b)-  char c   = ValueCode (char c) (char c)-  cons     = ValueCode cons cons-  const    = ValueCode const const-  eq x     = ValueCode (eq (value x)) (eq (code x))-  flip     = ValueCode flip flip-  id       = ValueCode id id-  nil      = ValueCode nil nil-  unit     = ValueCode unit unit-  left     = ValueCode left left-  right    = ValueCode right right-  nothing  = ValueCode nothing nothing-  just     = ValueCode just just-instance Haskellable Value where-  (.)      = Value (Function..)-  ($)      = Value (Function.$)-  (.@) f x = Value (unValue f (unValue x))-  bool     = Value-  char     = Value-  cons     = Value (:)-  const    = Value Function.const-  eq x     = Value (unValue x Eq.==)-  flip     = Value Function.flip-  id       = Value Function.id-  nil      = Value []-  unit     = Value ()-  left     = Value Left-  right    = Value Right-  nothing  = Value Nothing-  just     = Value Just-instance Haskellable TH.CodeQ where-  (.)      = [|| (Function..) ||]-  ($)      = [|| (Function.$) ||]-  (.@) f x = [|| $$f $$x ||]-  bool b   = [|| b ||]-  char c   = [|| c ||]-  cons     = [|| (:) ||]-  const    = [|| Function.const ||]-  eq x     = [|| ($$x Eq.==) ||]-  flip     = [|| \f x y -> f y x ||]-  id       = [|| \x -> x ||]-  nil      = [|| [] ||]-  unit     = [|| () ||]-  left     = [|| Left ||]-  right    = [|| Right ||]-  nothing  = [|| Nothing ||]-  just     = [|| Just ||]+module Symantic.Parser.Haskell+  ( module Symantic.Parser.Haskell.Optimize+  , module Symantic.Parser.Haskell.Term+  , module Symantic.Parser.Haskell.View+  ) where+import Symantic.Parser.Haskell.Optimize+import Symantic.Parser.Haskell.Term+import Symantic.Parser.Haskell.View

@@ -0,0 +1,194 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+module Symantic.Parser.Haskell.Optimize where++import Data.Bool (Bool(..))+import Data.Functor.Identity (Identity(..))+import Data.String (String)+import Prelude (undefined)+import Text.Show (Show(..))+import qualified Data.Eq as Eq+import qualified Data.Function as Fun+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH++import Symantic.Univariant.Trans+import Symantic.Parser.Haskell.Term++-- * Type 'Term'+-- | Initial encoding of some 'Termable' symantics,+-- useful for some optimizations in 'optimizeTerm'.+data Term repr a where+  -- | Black-box for all terms neither interpreted nor pattern-matched.+  Term :: { unTerm :: repr a } -> Term repr a++  -- Terms useful for 'optimizeTerm'.+  (:@) :: Term repr (a->b) -> Term repr a -> Term repr b+  Lam :: (Term repr a -> Term repr b) -> Term repr (a->b)+  Lam1 :: (Term repr a -> Term repr b) -> Term repr (a->b)+  Var :: String -> Term repr a++  -- Terms useful for prettier dumps.+  Char :: (TH.Lift tok, Show tok) => tok -> Term repr tok+  Cons :: Term repr (a -> [a] -> [a])+  Eq :: Eq.Eq a => Term repr (a -> a -> Bool)+  {-+  Const :: Term repr (a -> b -> a)+  Flip :: Term repr ((a -> b -> c) -> b -> a -> c)+  Id :: Term repr (a->a)+  (:$) :: Term repr ((a->b) -> a -> b)+  -- (:.) :: Term repr ((b->c) -> (a->b) -> a -> c)+-- infixr 0 :$+-- infixr 9 :.+  -}+infixl 9 :@++type instance Output (Term repr) = repr+instance Trans repr (Term repr) where+  trans = Term++instance Termable repr => Termable (Term repr) where+  lam     = Lam+  lam1    = Lam1+  (.@)    = (:@)+  cons    = Cons+  eq      = Eq+  unit    = Term unit+  bool b  = Term (bool b)+  char    = Char+  nil     = Term nil+  left    = Term left+  right   = Term right+  nothing = Term nothing+  just    = Term just+  const   = Lam1 (\x -> Lam1 (\_y -> x))+  flip    = Lam1 (\f -> Lam1 (\x -> Lam1 (\y -> f .@ y .@ x)))+  id      = Lam1 (\x -> x)+  ($)     = Lam1 (\f -> Lam1 (\x -> f .@ x))+  (.)     = Lam1 (\f -> Lam1 (\g -> Lam1 (\x -> f .@ (g .@ x))))++-- | Beta-reduce the left-most outer-most lambda abstraction (aka. normal-order reduction),+-- but to avoid duplication of work, only those manually marked+-- as using their variable at most once.+-- This is mainly to get prettier splices.+-- +-- DOC: Demonstrating Lambda Calculus Reduction, Peter Sestoft, 2001,+-- https://www.itu.dk/people/sestoft/papers/sestoft-lamreduce.pdf+optimizeTerm :: Term repr a -> Term repr a+optimizeTerm = nor+  where+  -- | normal-order reduction+  nor :: Term repr a -> Term repr a+  nor = \case+    Lam f -> Lam (nor Fun.. f)+    Lam1 f -> Lam1 (nor Fun.. f)+    x :@ y -> case whnf x of+      Lam1 f -> nor (f y)+      x' -> nor x' :@ nor y+    x -> x+  -- | weak-head normal-form+  whnf :: Term repr a -> Term repr a+  whnf = \case+    x :@ y -> case whnf x of+      Lam1 f -> whnf (f y)+      x' -> x' :@ y+    x -> x++instance Trans (Term Identity) Identity where+  trans = \case+    Cons -> cons+    Char t -> char t+    Eq -> eq+    Term repr -> repr+    x :@ y -> Identity (runIdentity (trans x) (runIdentity (trans y)))+    Lam  f -> Identity (runIdentity Fun.. trans Fun.. f Fun.. Term Fun.. Identity)+    Lam1 f -> trans (Lam f)+    Var{} -> undefined+    {-+    Const -> const+    Flip -> flip+    Id -> id+    (:$) -> ($)+    -}+instance Trans (Term TH.CodeQ) TH.CodeQ where+  -- Superfluous pattern-matches are only+  -- out of a cosmetic concerns when reading *.dump-splices,+  -- not for optimizing, which is done in 'optimizeTerm'.+  trans = \case+    Cons :@ x :@ y -> [|| $$(trans x) : $$(trans y) ||]+    Cons :@ x -> [|| ($$(trans x) :) ||]+    Cons -> cons+    Char t -> char t+    Eq :@ x :@ y -> [|| $$(trans x) Eq.== $$(trans y) ||]+    Eq :@ x -> [|| ($$(trans x) Eq.==) ||]+    Eq -> eq+    Term repr -> repr+    -- (:$) :@ x -> [|| ($$(trans x) Fun.$) ||]+    -- (:.) :@ f :@ g -> [|| \xx -> $$(trans f) ($$(trans g) xx) ||]+    -- (:.) :@ (:.) -> [|| \f x -> (\g y -> (f x) (g y)) ||]+    -- (:.) :@ x :@ y -> [|| $$(trans x) Fun.. $$(trans y) ||]+    -- (:.) :@ x -> [|| ($$(trans x) Fun..) ||]+    -- (:.) :@ f -> [|| \g x -> $$(trans f) (g x) ||]+    -- (:.) -> (.)+    x :@ y -> [|| $$(trans x) $$(trans y) ||]+    Lam f -> [|| \x -> $$(trans (f (Term [||x||]))) ||]+    Lam1 f -> trans (Lam f)+    Var{} -> undefined+    {-+    Const -> const+    Flip -> flip+    Id -> id+    (:$) -> ($)+    -}+instance Trans (Term ValueCode) ValueCode where+  trans = \case+    Term x -> x+    Char c -> char c+    Cons -> cons+    Eq -> eq+    (:@) f x -> (.@) (trans f) (trans x)+    Lam f -> ValueCode+      { value = value Fun.. trans Fun.. f Fun.. Term Fun.. (`ValueCode` undefined)+      , code = [|| \x -> $$(code Fun.. trans Fun.. f Fun.. Term Fun.. (undefined `ValueCode`) Fun.$ [||x||]) ||]+      }+    Lam1 f -> trans (Lam f)+    Var{} -> undefined+    {-+    Const -> const+    Flip -> flip+    Id -> id+    (:$) -> ($)+    -}+instance Trans (Term ValueCode) (Term TH.CodeQ) where+  trans = \case+    Term x -> Term (code x)+    Char c -> char c+    Cons -> cons+    Eq -> eq+    (:@) f x -> (.@) (trans f) (trans x)+    Lam f -> Lam (\x -> trans (f (trans x)))+    Lam1 f -> Lam1 (\x -> trans (f (trans x)))+    Var v -> Var v+    {-+    Const -> const+    Flip -> flip+    Id -> id+    (:$) -> ($)+    -}+instance Trans (Term TH.CodeQ) (Term ValueCode) where+  trans = \case+    Term x -> Term (ValueCode undefined x)+    Char c -> char c+    Cons -> cons+    Eq -> eq+    (:@) f x -> (.@) (trans f) (trans x)+    Lam f -> Lam (\x -> trans (f (trans x)))+    Lam1 f -> Lam1 (\x -> trans (f (trans x)))+    Var v -> Var v+    {-+    Const -> const+    Flip -> flip+    Id -> id+    (:$) -> ($)+    -}

@@ -0,0 +1,194 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+-- | Haskell terms which are interesting+-- to pattern-match when optimizing.+module Symantic.Parser.Haskell.Term where++import Data.Bool (Bool(..))+import Data.Either (Either(..))+import Data.Eq (Eq)+import Data.Maybe (Maybe(..))+import Data.Functor.Identity (Identity(..))+import Prelude (undefined)+import Text.Show (Show(..))+import qualified Data.Eq as Eq+import qualified Data.Function as Fun+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH++import qualified Symantic.Univariant.Trans as Sym++-- * Class 'Termable'+-- | Single-out some Haskell terms in order to +class Termable repr where+  -- | Application, aka. unabstract.+  (.@) :: repr (a->b) -> repr a -> repr b+  -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.+  lam :: (repr a -> repr b) -> repr (a->b)+  -- | Like 'lam' but whose argument is used only once,+  -- hence safe to beta-reduce (inline) without duplicating work.+  lam1 :: (repr a -> repr b) -> repr (a->b)++  -- Singled-out terms+  bool :: Bool -> repr Bool+  char :: (TH.Lift tok, Show tok) => tok -> repr tok+  cons :: repr (a -> [a] -> [a])+  nil :: repr [a]+  eq :: Eq a => repr (a -> a -> Bool)+  unit :: repr ()+  left :: repr (l -> Either l r)+  right :: repr (r -> Either l r)+  nothing :: repr (Maybe a)+  just :: repr (a -> Maybe a)+  const :: repr (a -> b -> a)+  flip :: repr ((a -> b -> c) -> b -> a -> c)+  id :: repr (a->a)+  (.) :: repr ((b->c) -> (a->b) -> a -> c)+  ($) :: repr ((a->b) -> a -> b)++  default (.@) ::+    Sym.Liftable2 repr => Termable (Sym.Output repr) =>+    repr (a->b) -> repr a -> repr b+  default lam ::+    Sym.Liftable repr => Sym.Unliftable repr => Termable (Sym.Output repr) =>+    (repr a -> repr b) -> repr (a->b)+  default lam1 ::+    Sym.Liftable repr => Sym.Unliftable repr => Termable (Sym.Output repr) =>+    (repr a -> repr b) -> repr (a->b)+  default bool ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    Bool -> repr Bool+  default char ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    TH.Lift tok => Show tok =>+    tok -> repr tok+  default cons ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    repr (a -> [a] -> [a])+  default nil ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    repr [a]+  default eq ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    Eq a => repr (a -> a -> Bool)+  default unit ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    repr ()+  default left ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    repr (l -> Either l r)+  default right ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    repr (r -> Either l r)+  default nothing ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    repr (Maybe a)+  default just ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    repr (a -> Maybe a)+  default const ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    repr (a -> b -> a)+  default flip ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    repr ((a -> b -> c) -> b -> a -> c)+  default id ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    repr (a->a)+  default (.) ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    repr ((b->c) -> (a->b) -> a -> c)+  default ($) ::+    Sym.Liftable repr => Termable (Sym.Output repr) =>+    repr ((a->b) -> a -> b)++  (.@) = Sym.lift2 (.@)+  lam f = Sym.lift (lam (Sym.trans Fun.. f Fun.. Sym.trans))+  lam1 f = Sym.lift (lam1 (Sym.trans Fun.. f Fun.. Sym.trans))+  bool = Sym.lift Fun.. bool+  char = Sym.lift Fun.. char+  cons = Sym.lift cons+  nil = Sym.lift nil+  eq = Sym.lift eq+  unit = Sym.lift unit+  left = Sym.lift left+  right = Sym.lift right+  nothing = Sym.lift nothing+  just = Sym.lift just+  const = Sym.lift const+  flip = Sym.lift flip+  id = Sym.lift id+  (.) = Sym.lift (.)+  ($) = Sym.lift ($)+infixr 0 $+infixr 9 .+infixl 9 .@++-- * Type 'ValueCode'+data ValueCode a = ValueCode+  { value :: a+  , code :: TH.CodeQ a+  }+instance Termable ValueCode where+  f .@ x = ValueCode+    { value = runIdentity (Identity (value f) .@ (Identity (value x)))+    , code = code f .@ code x+    }+  lam f = ValueCode+    { value = runIdentity (lam (Identity Fun.. value Fun.. f Fun.. (`ValueCode` undefined) Fun.. runIdentity))+    , code  = lam (code Fun.. f Fun.. ValueCode undefined)+    }+  lam1     = lam+  bool b   = ValueCode (runIdentity (bool b)) (bool b)+  char c   = ValueCode (runIdentity (char c)) (char c)+  cons     = ValueCode (runIdentity cons) cons+  nil      = ValueCode (runIdentity nil) nil+  eq       = ValueCode (runIdentity eq) eq+  unit     = ValueCode (runIdentity unit) unit+  left     = ValueCode (runIdentity left) left+  right    = ValueCode (runIdentity right) right+  nothing  = ValueCode (runIdentity nothing) nothing+  just     = ValueCode (runIdentity just) just+  const    = ValueCode (runIdentity const) const+  flip     = ValueCode (runIdentity flip) flip+  id       = ValueCode (runIdentity id) id+  ($)      = ValueCode (runIdentity ($)) ($)+  (.)      = ValueCode (runIdentity (.)) (.)+instance Termable Identity where+  f .@ x   = Identity (runIdentity f (runIdentity x))+  lam f    = Identity (runIdentity Fun.. f Fun.. Identity)+  lam1     = lam+  bool     = Identity+  char     = Identity+  cons     = Identity (:)+  nil      = Identity []+  eq       = Identity (Eq.==)+  unit     = Identity ()+  left     = Identity Left+  right    = Identity Right+  nothing  = Identity Nothing+  just     = Identity Just+  const    = Identity Fun.const+  flip     = Identity Fun.flip+  id       = Identity Fun.id+  ($)      = Identity (Fun.$)+  (.)      = Identity (Fun..)+instance Termable TH.CodeQ where+  (.@) f x = [|| $$f $$x ||]+  lam f    = [|| \x -> $$(f [||x||]) ||]+  lam1     = lam+  bool b   = [|| b ||]+  char c   = [|| c ||]+  cons     = [|| (:) ||]+  nil      = [|| [] ||]+  eq       = [|| (Eq.==) ||]+  unit     = [|| () ||]+  left     = [|| Left ||]+  right    = [|| Right ||]+  nothing  = [|| Nothing ||]+  just     = [|| Just ||]+  const    = [|| Fun.const ||]+  id       = [|| \x -> x ||]+  flip     = [|| \f x y -> f y x ||]+  ($)      = [|| (Fun.$) ||]+  (.)      = [|| (Fun..) ||]

@@ -0,0 +1,114 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Symantic.Parser.Haskell.View where++import Data.Bool+import Data.Function (($), (.))+import Data.Int (Int)+import Data.Semigroup (Semigroup(..))+import Data.String (IsString(..), String)+import Prelude ((+))+import Text.Show (Show(..), ShowS, shows, showParen, showString)+import qualified Data.Function as Fun++import Symantic.Parser.Grammar.Fixity+import qualified Symantic.Parser.Haskell.Optimize as H++-- * Type 'ViewTerm'+newtype ViewTerm a = ViewTerm { unViewTerm :: ViewTermInh -> ShowS }++instance IsString (ViewTerm a) where+  fromString s = ViewTerm $ \_inh -> showString s++-- ** Type 'ViewTermInh'+data ViewTermInh+ =   ViewTermInh+ {   viewTermInh_op :: (Infix, Side)+ ,   viewTermInh_pair :: Pair+ ,   viewTermInh_lamDepth :: Int+ }++pairViewTerm :: ViewTermInh -> Infix -> ShowS -> ShowS+pairViewTerm inh op s =+  if isPairNeeded (viewTermInh_op inh) op+  then showString o . s . showString c+  else s+  where (o,c) = viewTermInh_pair inh++instance Show (ViewTerm a) where+  showsPrec p v = unViewTerm v ViewTermInh+    { viewTermInh_op = (infixN p, SideL)+    , viewTermInh_pair = pairParen+    , viewTermInh_lamDepth = 1+    }+instance Show (H.Term repr a) where+  showsPrec p = showsPrec p . go+    where+    go :: forall b. H.Term repr b -> ViewTerm b+    go = \case+      H.Term{} -> "Term"+      {-+      (H.:.) H.:@ f H.:@ g -> ViewTerm $ \inh ->+        pairViewTerm inh op Fun.$+          unViewTerm (go f) inh{viewTermInh_op=op} Fun..+          showString " . " Fun..+          unViewTerm (go g) inh{viewTermInh_op=op}+        where op = infixR 9+      (H.:.) -> "(.)"+      -}+      {-+      H.Char t -> ViewTerm $ \_inh ->+        showString "(char " .+        shows t .+        showString ")"+      -}+      H.Char t -> ViewTerm $ \_inh -> shows t+      H.Cons H.:@ x H.:@ xs -> ViewTerm $ \inh ->+        pairViewTerm inh op Fun.$+          unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..+          showString " : " Fun..+          unViewTerm (go xs) inh{viewTermInh_op=(op, SideR)}+        where op = infixN 5+      H.Cons -> "cons"+      H.Eq H.:@ x H.:@ y -> ViewTerm $ \inh ->+        pairViewTerm inh op Fun.$+          unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..+          showString " == " Fun..+          unViewTerm (go y) inh{viewTermInh_op=(op, SideR)}+        where op = infixN 4+      H.Eq H.:@ x -> ViewTerm $ \inh ->+        showParen True Fun.$+          unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..+          showString " =="+          where op = infixN 4+      H.Eq -> "(==)"+      H.Var v -> fromString v+      H.Lam1 f -> viewLam "u" f+      H.Lam f -> viewLam "x" f+      f H.:@ x -> ViewTerm $ \inh ->+        pairViewTerm inh op $+          unViewTerm (go f) inh{viewTermInh_op = (op, SideL) } .+          -- showString " :@ " .+          showString " " .+          unViewTerm (go x) inh{viewTermInh_op = (op, SideR) }+        where op = infixN 10+      {-+      H.Const -> "const"+      H.Flip -> "flip"+      H.Id -> "id"+      (H.:$) -> "($)"+      -}+    viewLam :: forall b c. String -> (H.Term repr b -> H.Term repr c) -> ViewTerm (b -> c)+    viewLam v f = ViewTerm $ \inh ->+      pairViewTerm inh op $+        let x = v<>show (viewTermInh_lamDepth inh) in+        -- showString "Lam1 (" .+        showString "\\" . showString x . showString " -> " .+        (unViewTerm (go (f (H.Var x))) inh+          { viewTermInh_op = (op, SideL)+          , viewTermInh_lamDepth = viewTermInh_lamDepth inh + 1+          })+        -- . showString ")"+      where op = infixN 0

@@ -1,35 +1,40 @@ module Symantic.Parser.Machine- ( module Symantic.Parser.Machine- , module Symantic.Parser.Machine.Instructions- , module Symantic.Parser.Machine.Dump- , module Symantic.Parser.Machine.Generate- , module Symantic.Parser.Machine.Input- ) where+  ( module Symantic.Parser.Machine+  , module Symantic.Parser.Machine.Generate+  , module Symantic.Parser.Machine.Input+  , module Symantic.Parser.Machine.Instructions+  , module Symantic.Parser.Machine.Optimize+  , module Symantic.Parser.Machine.Program+  , module Symantic.Parser.Machine.View+  ) where import Data.Function ((.)) import Data.Ord (Ord)-import Symantic.Parser.Machine.Input-import Symantic.Parser.Grammar import Text.Show (Show) import qualified Language.Haskell.TH.Syntax as TH -import Symantic.Parser.Machine.Instructions-import Symantic.Parser.Machine.Dump+import Symantic.Parser.Grammar import Symantic.Parser.Machine.Generate+import Symantic.Parser.Machine.Input+import Symantic.Parser.Machine.Instructions+import Symantic.Parser.Machine.Optimize+import Symantic.Parser.Machine.Program+import Symantic.Parser.Machine.View  -- * Type 'Parser'-type Parser inp =+type Parser inp = ParserRepr Gen inp++-- | Like a 'Parser' but not bound to the 'Gen' interpreter.+type ParserRepr repr inp =   ObserveSharing TH.Name-                 (OptimizeComb TH.Name-                               (Machine inp))+                 (OptimizeGrammar (Program repr inp)) +-- | Build a 'Machine' able to 'generateCode' for the given 'Parser'. machine :: forall inp repr a.   Ord (InputToken inp) =>   Show (InputToken inp) =>   TH.Lift (InputToken inp) =>-  -- InputToken inp ~ Char =>-  Executable repr =>-  Readable repr (InputToken inp) =>-  Grammar (Machine inp) =>-  Parser inp a ->+  Grammar (InputToken inp) (Program repr inp) =>+  Machine (InputToken inp) repr =>+  ParserRepr repr inp a ->   repr inp '[] ('Succ 'Zero) a-machine = runMachine . optimizeComb . observeSharing+machine = optimizeMachine . grammar @(InputToken inp)

@@ -1,82 +0,0 @@-module Symantic.Parser.Machine.Dump where--import Data.Function (($), (.), id)-import Data.Functor ((<$>))-import Data.Kind (Type)-import Data.Semigroup (Semigroup(..))-import Data.String (String, IsString(..))-import Text.Show (Show(..))-import qualified Data.Tree as Tree-import qualified Data.List as List--import Symantic.Parser.Machine.Instructions---- * Type 'DumpInstr'-newtype DumpInstr inp (vs:: [Type]) (es::Peano) a-  =     DumpInstr { unDumpInstr ::-  Tree.Forest String -> Tree.Forest String }--dumpInstr :: DumpInstr inp vs es a -> DumpInstr inp vs es a-dumpInstr = id---- | Helper to dump a command.-dumpInstrCmd :: String -> Tree.Forest String -> Tree.Tree String-dumpInstrCmd n = Tree.Node n--- | Helper to dump an argument.-dumpInstrArg :: String -> Tree.Forest String -> Tree.Tree String-dumpInstrArg n = Tree.Node ("<"<>n<>">")--instance Show (DumpInstr inp vs es a) where-  show = drawTree . Tree.Node "" . ($ []) . unDumpInstr-    where-    drawTree :: Tree.Tree String -> String-    drawTree  = List.unlines . draw-    draw :: Tree.Tree String -> [String]-    draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0-      where-      drawSubTrees [] = []-      drawSubTrees [t] = shift "" "  " (draw t)-      drawSubTrees (t:ts) = shift "" "| " (draw t) <> drawSubTrees ts-      shift first other = List.zipWith (<>) (first : List.repeat other)-instance IsString (DumpInstr inp vs es a) where-  fromString s = DumpInstr $ \is -> Tree.Node (fromString s) [] : is--instance Stackable DumpInstr where-  push a k = DumpInstr $ \is -> dumpInstrCmd ("push "<>showsPrec 10 a "") [] : unDumpInstr k is-  pop k = DumpInstr $ \is -> dumpInstrCmd "pop" [] : unDumpInstr k is-  liftI2 f k = DumpInstr $ \is -> dumpInstrCmd ("lift "<>show f) [] : unDumpInstr k is-  swap k = DumpInstr $ \is -> dumpInstrCmd "swap" [] : unDumpInstr k is-instance Branchable DumpInstr where-  case_ l r = DumpInstr $ \is -> dumpInstrCmd "case"-    [ dumpInstrArg "left" (unDumpInstr l [])-    , dumpInstrArg "right" (unDumpInstr r [])-    ] : is-  choices ps bs d = DumpInstr $ \is ->-    dumpInstrCmd ("choices "<>show ps) (-      (dumpInstrArg "branch" . ($ []) . unDumpInstr <$> bs) <>-      [ dumpInstrArg "default" (unDumpInstr d []) ]-    ) : is-instance Failable DumpInstr where-  fail _err = DumpInstr $ \is -> dumpInstrCmd "fail" [] : is-  popFail k = DumpInstr $ \is -> dumpInstrCmd "popFail" [] : unDumpInstr k is-  catchFail t h = DumpInstr $ \is -> dumpInstrCmd "catchFail"-    [ dumpInstrArg "try" (unDumpInstr t [])-    , dumpInstrArg "handler" (unDumpInstr h [])-    ] : is-instance Inputable DumpInstr where-  loadInput k = DumpInstr $ \is -> dumpInstrCmd "loadInput" [] : unDumpInstr k is-  pushInput k = DumpInstr $ \is -> dumpInstrCmd "pushInput" [] : unDumpInstr k is-instance Routinable DumpInstr where-  subroutine n sub k = DumpInstr $ \is ->-    Tree.Node (show n<>":") (unDumpInstr sub [])-    : unDumpInstr k is-  jump n = DumpInstr $ \is -> dumpInstrCmd ("jump "<>show n) [] : is-  call n k = DumpInstr $ \is -> dumpInstrCmd ("call "<>show n) [] : unDumpInstr k is-  ret = DumpInstr $ \is -> dumpInstrCmd "ret" [] : is-instance Joinable DumpInstr where-  defJoin n sub k = DumpInstr $ \is ->-    Tree.Node (show n<>":") (unDumpInstr sub [])-    : unDumpInstr k is-  refJoin n = DumpInstr $ \is -> dumpInstrCmd ("refJoin "<>show n) [] : is-instance Readable DumpInstr inp where-  read _es _p k = DumpInstr $ \is -> dumpInstrCmd "read" [] : unDumpInstr k is

@@ -9,19 +9,22 @@ import Data.Bool (Bool) import Data.Char (Char) import Data.Either (Either(..))-import Data.Function (($))--- import Data.Functor ((<$>))+import Data.Function (($), (.))+import Data.Functor ((<$>)) import Data.Int (Int)+import Data.List (minimum)+import Data.Map (Map) import Data.Maybe (Maybe(..))-import Data.Ord (Ord, Ordering(..))+import Data.Ord (Ord(..), Ordering(..)) import Data.Semigroup (Semigroup(..)) import Data.Set (Set) import Language.Haskell.TH (CodeQ, Code(..))-import Prelude (($!))+import Prelude ((+), (-)) import Text.Show (Show(..))-import qualified Data.Eq as Eq+import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Language.Haskell.TH.Syntax as TH+-- import qualified Control.Monad.Trans.Writer as Writer  import Symantic.Univariant.Trans import Symantic.Parser.Grammar.Combinators (ErrorItem(..))@@ -29,17 +32,31 @@ import Symantic.Parser.Machine.Instructions import qualified Symantic.Parser.Haskell as H +genCode :: TermInstr a -> CodeQ a+genCode = trans+ -- * Type 'Gen' -- | Generate the 'CodeQ' parsing the input.-newtype Gen inp vs es a = Gen { unGen ::-  GenCtx inp vs es a ->-  CodeQ (Either (ParsingError inp) a)-}+data Gen inp vs es a = Gen+  { minHorizon :: Map TH.Name Horizon -> Horizon+    -- ^ Synthetized (bottom-up) minimal input length+    -- required by the parser to not fail.+    -- This requires a 'minHorizonByName'+    -- containing the minimal 'Horizon's of all the 'TH.Name's+    -- this parser 'call's, 'jump's or 'refJoin's to.+  , unGen ::+      GenCtx inp vs es a ->+      CodeQ (Either (ParsingError inp) a)+  }  -- ** Type 'ParsingError' data ParsingError inp   =  ParsingErrorStandard   {  parsingErrorOffset :: Offset+    -- | Note that if an 'ErrorItemHorizon' greater than 1+    -- is amongst the 'parsingErrorExpecting'+    -- then this is only the 'InputToken'+    -- at the begining of the expected 'Horizon'.   ,  parsingErrorUnexpected :: Maybe (InputToken inp)   ,  parsingErrorExpecting :: Set (ErrorItem (InputToken inp))   }@@ -48,6 +65,14 @@ -- ** Type 'Offset' type Offset = Int +-- ** Type 'Horizon'+-- | Synthetized minimal input length+-- required for a successful parsing.+-- Used with 'checkedHorizon' to factorize input length checks,+-- instead of checking the input length+-- one 'InputToken' at a time at each 'read'.+type Horizon = Offset+ -- ** Type 'Cont' type Cont inp v a =   {-farthestInput-}Cursor inp ->@@ -56,13 +81,6 @@   Cursor inp ->   Either (ParsingError inp) a --- ** Type 'SubRoutine'-type SubRoutine inp v a =-  {-ok-}Cont inp v a ->-  Cursor inp ->-  {-ko-}FailHandler inp a ->-  Either (ParsingError inp) a- -- ** Type 'FailHandler' type FailHandler inp a =   {-failureInput-}Cursor inp ->@@ -78,9 +96,9 @@   } -} --- | @('generate' input mach)@ generates @TemplateHaskell@ code--- parsing given 'input' according to given 'mach'ine.-generate ::+-- | @('generateCode' input mach)@ generates @TemplateHaskell@ code+-- parsing the given 'input' according to the given 'Machine'.+generateCode ::   forall inp ret.   Ord (InputToken inp) =>   Show (InputToken inp) =>@@ -91,7 +109,7 @@   Show (Cursor inp) =>   Gen inp '[] ('Succ 'Zero) ret ->   CodeQ (Either (ParsingError inp) ret)-generate input (Gen k) = [||+generateCode input k = [||   -- Pattern bindings containing unlifted types   -- should use an outermost bang pattern.   let !(# init, readMore, readNext #) = $$(cursorOf input) in@@ -105,7 +123,7 @@             else Nothing         , parsingErrorExpecting = Set.fromList farExp         } in-  $$(k GenCtx+  $$(unGen k GenCtx     { valueStack = ValueStackEmpty     , failStack = FailStackCons [||finalFail||] FailStackEmpty     , retCode = [||finalRet||]@@ -115,11 +133,14 @@     -- , farthestError = [||Nothing||]     , farthestInput = [||init||]     , farthestExpecting = [|| [] ||]+    , checkedHorizon = 0+    , minHorizonByName = Map.empty     })   ||]  -- ** Type 'GenCtx'--- | This is a context only present at compile-time.+-- | This is an inherited (top-down) context+-- only present at compile-time, to build TemplateHaskell splices. data GenCtx inp vs (es::Peano) a =   ( TH.Lift (InputToken inp)   , Cursorable (Cursor inp)@@ -127,290 +148,322 @@   -- , InputToken inp ~ Char   ) => GenCtx   { valueStack :: ValueStack vs-  , failStack :: FailStack inp es a+  , failStack :: FailStack inp a es+  --, failStacks :: FailStack inp es a   , retCode :: CodeQ (Cont inp a a)   , input :: CodeQ (Cursor inp)   , moreInput :: CodeQ (Cursor inp -> Bool)   , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))   , farthestInput :: CodeQ (Cursor inp)   , farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]+    -- | Remaining horizon already checked.+    -- Updated by 'checkHorizon'+    -- and reset elsewhere when needed.+  , checkedHorizon :: Offset+    -- | Minimal horizon for each 'subroutine' or 'defJoin'.+    -- This can be done as an inherited attribute because+    -- 'OverserveSharing' introduces 'def' as an ancestor node+    -- of all the 'ref's pointing to it.+    -- Same for 'defJoin' and its 'refJoin's.+  , minHorizonByName :: Map TH.Name Offset   }  -- ** Type 'ValueStack' data ValueStack vs where   ValueStackEmpty :: ValueStack '[]   ValueStackCons ::-    -- TODO: maybe use H.Haskell instead of CodeQ ?-    -- as in https://github.com/j-mie6/ParsleyHaskell/popFail/3ec0986a5017866919a6404c14fe78678b7afb46-    { valueStackHead :: CodeQ v+    { valueStackHead :: TermInstr v     , valueStackTail :: ValueStack vs     } -> ValueStack (v ': vs)  -- ** Type 'FailStack'-data FailStack inp es a where-  FailStackEmpty :: FailStack inp 'Zero a+data FailStack inp a es where+  FailStackEmpty :: FailStack inp a 'Zero   FailStackCons ::     { failStackHead :: CodeQ (FailHandler inp a)-    , failStackTail :: FailStack inp es a+    , failStackTail :: FailStack inp a es     } ->-    FailStack inp ('Succ es) a+    FailStack inp a ('Succ es)  instance Stackable Gen where-  push x k = Gen $ \ctx -> unGen k ctx-    { valueStack = ValueStackCons (liftCode x) (valueStack ctx) }-  pop k = Gen $ \ctx -> unGen k ctx-    { valueStack = valueStackTail (valueStack ctx) }-  liftI2 f k = Gen $ \ctx -> unGen k ctx-    { valueStack =-      let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in-      ValueStackCons (liftCode2 f x y) xs+  push x k = k+    { unGen = \ctx -> unGen k ctx+      { valueStack = ValueStackCons x (valueStack ctx) }     }-  swap k = Gen $ \ctx -> unGen k ctx-    { valueStack =+  pop k = k+    { unGen = \ctx -> unGen k ctx+      { valueStack = valueStackTail (valueStack ctx) }+    }+  liftI2 f k = k+    { unGen = \ctx -> unGen k ctx+      { valueStack =         let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in-        ValueStackCons x (ValueStackCons y xs)+        ValueStackCons (f H.:@ x H.:@ y) xs+      }     }+  swap k = k+    { unGen = \ctx -> unGen k ctx+      { valueStack =+          let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in+          ValueStackCons x (ValueStackCons y xs)+      }+    } instance Branchable Gen where-  case_ kx ky = Gen $ \ctx ->-    let ValueStackCons v vs = valueStack ctx in-    [||-      case $$v of-        Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons [||x||] vs })-        Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons [||y||] vs })-    ||]-  choices fs ks kd = Gen $ \ctx ->-    let ValueStackCons v vs = valueStack ctx in-    go ctx{valueStack = vs} v fs ks+  caseI kx ky = Gen+    { minHorizon = \ls ->+      minHorizon kx ls `min` minHorizon ky ls+    , unGen = \ctx ->+      let ValueStackCons v vs = valueStack ctx in+      [||+        case $$(genCode v) of+          Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons (H.Term [||x||]) vs })+          Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (H.Term [||y||]) vs })+      ||]+    }+  choices fs ks kd = Gen+    { minHorizon = \hs -> minimum $+        minHorizon kd hs :+        (($ hs) . minHorizon <$> ks)+    , unGen = \ctx ->+      let ValueStackCons v vs = valueStack ctx in+      go ctx{valueStack = vs} v fs ks+    }     where-    go ctx x (f:fs') (Gen k:ks') = [||-      if $$(liftCode1 f x) then $$(k ctx)+    go ctx x (f:fs') (k:ks') = [||+      if $$(genCode (f H.:@ x))+      then $$(unGen k ctx)       else $$(go ctx x fs' ks')       ||]     go ctx _ _ _ = unGen kd ctx instance Failable Gen where-  fail failExp = Gen $ \ctx@GenCtx{} -> [||-    let (# farInp, farExp #) =-          case $$compareOffset $$(farthestInput ctx) $$(input ctx) of-            LT -> (# $$(input ctx), failExp #)-            EQ -> (# $$(farthestInput ctx), ($$(farthestExpecting ctx) <> failExp) #)-            GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #) in-    {--    trace ("fail: "-      <>" failExp="<>show @[ErrorItem Char] failExp-      <>" farthestExpecting="<>show @[ErrorItem Char] ($$(farthestExpecting ctx))-      <>" farExp="<>show @[ErrorItem Char] farExp) $-    -}-    $$(failStackHead (failStack ctx))-      $$(input ctx) farInp farExp-    ||]-  popFail k = Gen $ \ctx ->-    let FailStackCons _e es = failStack ctx in-    unGen k ctx{failStack = es}-  catchFail ok ko = Gen $ \ctx@GenCtx{} -> [||-    let _ = "catchFail" in $$(unGen ok ctx-      { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->-          -- trace ("catchFail: " <> "farExp="<>show farExp) $-          $$(unGen ko ctx-            -- Push the input as it was when entering the catchFail.-            { valueStack = ValueStackCons (input ctx) (valueStack ctx)-            -- Move the input to the failing position.-            , input = [||failInp||]-            -- Set the farthestInput to the farthest computed by 'fail'-            , farthestInput = [||farInp||]-            , farthestExpecting = [||farExp||]-            })-        ||] (failStack ctx)-      })-    ||]+  fail failExp = Gen+    { minHorizon = \_hs -> 0+    , unGen = \ctx@GenCtx{} -> [||+      let (# farInp, farExp #) =+            case $$compareOffset $$(farthestInput ctx) $$(input ctx) of+              LT -> (# $$(input ctx), failExp #)+              EQ -> (# $$(farthestInput ctx), ($$(farthestExpecting ctx) <> failExp) #)+              GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #) in+      $$(failStackHead (failStack ctx))+        $$(input ctx) farInp farExp+      ||]+    }+  popFail k = k+    { unGen = \ctx ->+      unGen k ctx{failStack = failStackTail (failStack ctx)}+    }+  catchFail ok ko = Gen+    { minHorizon = \ls -> minHorizon ok ls `min` minHorizon ko ls+    , unGen = \ctx@GenCtx{} -> unGen ok ctx+        { failStack = FailStackCons [|| \ !failInp !farInp !farExp ->+            -- trace ("catchFail: " <> "farExp="<>show farExp) $+            $$(unGen ko ctx+              -- Push the input as it was when entering the catchFail.+              { valueStack = ValueStackCons (H.Term (input ctx)) (valueStack ctx)+              -- Move the input to the failing position.+              , input = [||failInp||]+              -- Set the farthestInput to the farthest computed by 'fail'+              , farthestInput = [||farInp||]+              , farthestExpecting = [||farExp||]+              })+          ||] (failStack ctx)+        }+    } instance Inputable Gen where-  loadInput k = Gen $ \ctx ->-    let ValueStackCons input vs = valueStack ctx in-    unGen k ctx{valueStack = vs, input}-  pushInput k = Gen $ \ctx ->-    unGen k ctx{valueStack = ValueStackCons (input ctx) (valueStack ctx)}+  loadInput k = k+    { unGen = \ctx ->+      let ValueStackCons input vs = valueStack ctx in+      unGen k ctx+        { valueStack = vs+        , input = genCode input+        , checkedHorizon = 0+        }+    }+  pushInput k = k+    { unGen = \ctx ->+      unGen k ctx{valueStack = ValueStackCons (H.Term (input ctx)) (valueStack ctx)}+    } instance Routinable Gen where-  call (LetName n) k = Gen $ \ctx -> [||-    let _ = "call" in-    $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))-      $$(suspend k ctx)-      $$(input ctx)-      $! $$(failStackHead (failStack ctx))-    ||]-  jump (LetName n) = Gen $ \ctx -> [||-    let _ = "jump" in-    $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))-      $$(retCode ctx)-      $$(input ctx)-      $! $$(failStackHead (failStack ctx))-    ||]-  ret = Gen $ \ctx -> unGen (resume (retCode ctx)) ctx-  subroutine (LetName n) sub k = Gen $ \ctx -> Code $ TH.unsafeTExpCoerce $ do-    body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley-      -- SubRoutine-      -- Why using $! at call site and not ! here on ko?-      \ !ok !inp ko ->-        $$(unGen sub ctx-          { valueStack = ValueStackEmpty-          , failStack = FailStackCons [||ko||] FailStackEmpty-          , input = [||inp||]-          , retCode = [||ok||]-          -- , farthestInput = [|inp|]-          -- , farthestExpecting = [|| [] ||]-          })+  subroutine (LetName n) sub k = Gen+    { minHorizon = minHorizon k+    , unGen = \ctx -> Code $ TH.unsafeTExpCoerce $ do+      -- 'sub' is recursively 'call'able within 'sub',+      -- but its maximal 'minHorizon' is not known yet.+      let minHorizonByNameButSub = Map.insert n 0 (minHorizonByName ctx)+      body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley+        -- subroutine called by 'call' or 'jump'+        \ !ok{-from generateSuspend or retCode-}+          !inp+          !ko{-from failStackHead-} ->+          $$(unGen sub ctx+            { valueStack = ValueStackEmpty+            , failStack = FailStackCons [||ko||] FailStackEmpty+            , input = [||inp||]+            , retCode = [||ok||]++            -- These are passed by the caller via 'ok' or 'ko'+            -- , farthestInput = +            -- , farthestExpecting = ++            -- Some callers can call this subroutine+            -- with zero checkedHorizon, hence use this minimum.+            -- TODO: maybe it could be improved a bit+            -- by taking the minimum of the checked horizons+            -- before all the 'call's and 'jump's to this subroutine.+            , checkedHorizon = 0+            , minHorizonByName = minHorizonByNameButSub+            })+        ||]+      let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]+      expr <- TH.unTypeQ (TH.examineCode (unGen k ctx+        { minHorizonByName =+            -- 'sub' is 'call'able within 'k'.+            Map.insert n+              (minHorizon sub minHorizonByNameButSub)+              (minHorizonByName ctx)+        }))+      return (TH.LetE [decl] expr)+    }+  jump (LetName n) = Gen+    { minHorizon = (Map.! n)+    , unGen = \ctx -> [||+      let _ = "jump" in+      $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))+        {-ok-}$$(retCode ctx)+        $$(input ctx)+        $$(failStackHead (failStack ctx))       ||]-    let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]-    expr <- TH.unTypeQ (TH.examineCode (unGen k ctx))-    return (TH.LetE [decl] expr)+    }+  call (LetName n) k = k+    { minHorizon = (Map.! n)+    , unGen = \ctx -> [||+      let _ = "call" in+      $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))+        {-ok-}$$(generateSuspend k ctx)+        $$(input ctx)+        $$(failStackHead (failStack ctx))+      ||]+    }+  ret = Gen+    { minHorizon = \_hs -> 0+    , unGen = \ctx -> unGen (generateResume (retCode ctx)) ctx+    } -suspend ::+-- | Generate a continuation to be called with 'generateResume',+-- used when 'call' 'ret'urns.+-- The return 'v'alue is 'push'ed on the 'valueStack'.+generateSuspend ::   {-k-}Gen inp (v ': vs) es a ->   GenCtx inp vs es a ->   CodeQ (Cont inp v a)-suspend k ctx = [||+generateSuspend k ctx = [||   let _ = "suspend" in   \farInp farExp v !inp ->     $$(unGen k ctx-      { valueStack = ValueStackCons [||v||] (valueStack ctx)+      { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)       , input = [||inp||]       , farthestInput = [||farInp||]       , farthestExpecting = [||farExp||]+      , checkedHorizon = 0       }     )   ||] -resume :: CodeQ (Cont inp v a) -> Gen inp (v ': vs) es a-resume k = Gen $ \ctx -> [||-  let _ = "resume" in-  $$k-    $$(farthestInput ctx)-    $$(farthestExpecting ctx)-    $$(valueStackHead (valueStack ctx))-    $$(input ctx)-  ||]+-- | Generate a call to the 'generateSuspend' continuation.+-- Used when 'call' 'ret'urns.+generateResume ::+  CodeQ (Cont inp v a) ->+  Gen inp (v ': vs) es a+generateResume k = Gen+  { minHorizon = \_hs -> 0+  , unGen = \ctx -> [||+    let _ = "resume" in+    $$k+      $$(farthestInput ctx)+      $$(farthestExpecting ctx)+      (let _ = "resume.genCode" in $$(genCode (valueStackHead (valueStack ctx))))+      $$(input ctx)+    ||]+  }  instance Joinable Gen where-  defJoin (LetName n) sub k = Gen $ \ctx -> Code $ TH.unsafeTExpCoerce $ do-    body <- TH.unTypeQ $ TH.examineCode $ [||-      \farInp farExp v !inp ->-        $$(unGen sub ctx-          { valueStack = ValueStackCons [||v||] (valueStack ctx)-          , input = [||inp||]-          , farthestInput = [||farInp||]-          , farthestExpecting = [||farExp||]-          })-      ||]-    let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]-    expr <- TH.unTypeQ (TH.examineCode (unGen k ctx))-    return (TH.LetE [decl] expr)-  refJoin (LetName n) =-    resume (Code (TH.unsafeTExpCoerce (return (TH.VarE n))))-instance Readable Gen Char where-  read farExp p k =-    -- TODO: piggy bank-    maybeEmitCheck (Just 1) k-    where-    maybeEmitCheck Nothing ok = sat (liftCode p) ok (fail farExp)-    maybeEmitCheck (Just n) ok = Gen $ \ctx ->-      let FailStackCons e es = failStack ctx in-      [||-      let readFail = $$(e) in -- Factorize failure code-      $$((`unGen` ctx{failStack = FailStackCons [||readFail||] es}) $ emitLengthCheck n-        {-ok-}(sat (liftCode p) ok-          {-ko-}(fail farExp))-        {-ko-}(fail farExp))-      ||]+  defJoin (LetName n) joined k = k+    { minHorizon = minHorizon k+    , unGen = \ctx -> Code $ TH.unsafeTExpCoerce $ do+      body <- TH.unTypeQ $ TH.examineCode $ [||+        \farInp farExp v !inp ->+          $$(unGen joined ctx+            { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)+            , input = [||inp||]+            , farthestInput = [||farInp||]+            , farthestExpecting = [||farExp||]+            , checkedHorizon = 0+            })+        ||]+      let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]+      expr <- TH.unTypeQ (TH.examineCode (unGen k ctx+        { minHorizonByName =+            -- 'joined' is 'refJoin'able within 'k'.+            Map.insert n+              -- By definition (in 'joinNext')+              -- 'joined' is not recursively 'refJoin'able within 'joined',+              -- hence no need to prevent against recursivity+              -- as has to be done in 'subroutine'.+              (minHorizon joined (minHorizonByName ctx))+              (minHorizonByName ctx)+        }))+      return (TH.LetE [decl] expr)+    }+  refJoin (LetName n) = (generateResume (Code (TH.unsafeTExpCoerce (return (TH.VarE n)))))+    { minHorizon = (Map.! n)+    }+instance Readable Char Gen where+  read farExp p = checkHorizon . checkToken farExp p -sat ::+checkHorizon ::+  TH.Lift (InputToken inp) =>+  {-ok-}Gen inp vs ('Succ es) a ->+  Gen inp vs ('Succ es) a+checkHorizon ok = ok+  { minHorizon = \hs -> 1 + minHorizon ok hs+  , unGen = \ctx0@GenCtx{failStack = FailStackCons e es} -> [||+      -- Factorize failure code+      let readFail = $$(e) in+      $$(+        let ctx = ctx0{ failStack = FailStackCons [||readFail||] es } in+        if checkedHorizon ctx >= 1+        then unGen ok ctx0{checkedHorizon = checkedHorizon ctx - 1}+        else let minHoriz = minHorizon ok (minHorizonByName ctx) in+          [||+          if $$(moreInput ctx)+               $$(if minHoriz > 0+                 then [||$$shiftRight minHoriz $$(input ctx)||]+                 else input ctx)+          then $$(unGen ok ctx{checkedHorizon = minHoriz})+          else let _ = "checkHorizon.else" in+            $$(unGen (fail [ErrorItemHorizon (minHoriz + 1)]) ctx)+          ||]+      )+    ||]+  }++checkToken ::   forall inp vs es a.-  -- Cursorable (Cursor inp) =>-  -- InputToken inp ~ Char =>   Ord (InputToken inp) =>   TH.Lift (InputToken inp) =>-  {-predicate-}CodeQ (InputToken inp -> Bool) ->+  [ErrorItem (InputToken inp)] ->+  {-predicate-}TermInstr (InputToken inp -> Bool) ->   {-ok-}Gen inp (InputToken inp ': vs) ('Succ es) a ->-  {-ko-}Gen inp vs ('Succ es) a ->   Gen inp vs ('Succ es) a-sat p ok ko = Gen $ \ctx -> [||-  let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in-  if $$p c-  then $$(unGen ok ctx-    { valueStack = ValueStackCons [||c||] (valueStack ctx)-    , input = [||cs||]-    })-  else let _ = "sat.else" in $$(unGen ko ctx)-  ||]--{--evalSat ::-  -- Cursorable inp =>-  -- HandlerOps inp =>-  InstrPure (Char -> Bool) ->-  Gen inp (Char ': vs) ('Succ es) a ->-  Gen inp vs ('Succ es) a-evalSat p k = do-  bankrupt <- asks isBankrupt-  hasChange <- asks hasCoin-  if | bankrupt -> maybeEmitCheck (Just 1) <$> k-     | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k-     | otherwise -> local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)-  where-  maybeEmitCheck Nothing mk ctx = sat (genDefunc p) mk (raise ctx) ctx-  maybeEmitCheck (Just n) mk ctx =-    [|| let bad = $$(raise ctx) in $$(emitLengthCheck n (sat (genDefunc p) mk [||bad||]) [||bad||] ctx)||]--}--emitLengthCheck ::-  TH.Lift (InputToken inp) =>-  Int -> Gen inp vs es a -> Gen inp vs es a -> Gen inp vs es a-emitLengthCheck 0 ok _ko = ok-emitLengthCheck 1 ok ko = Gen $ \ctx -> [||-  if $$(moreInput ctx) $$(input ctx)-  then $$(unGen ok ctx)-  else let _ = "sat.length-check.else" in $$(unGen ko ctx)-  ||]-{--emitLengthCheck n ok ko ctx = Gen $ \ctx -> [||-  if $$moreInput ($$shiftRight $$(input ctx) (n - 1))-  then $$(unGen ok ctx)-  else $$(unGen ko ctx {farthestExpecting = [||farExp||]})-  ||]--}---liftCode :: InstrPure a -> CodeQ a-liftCode = trans-{-# INLINE liftCode #-}--liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b-liftCode1 p a = case p of-  InstrPureSameOffset -> [|| $$sameOffset $$a ||]-  InstrPureHaskell h -> go a h-  where-  go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b-  go qa = \case-    (H.:$) -> [|| \x -> $$qa x ||]-    (H.:.) -> [|| \g x -> $$qa (g x) ||]-    H.Flip -> [|| \x y -> $$qa y x ||]-    (H.:.) H.:@ f H.:@ g -> [|| $$(go (go qa g) f) ||]-    H.Const -> [|| \_ -> $$qa ||]-    H.Flip H.:@ H.Const -> H.id-    h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]-    H.Eq x -> [|| $$(trans x) Eq.== $$qa ||]-    H.Id -> qa-    h -> [|| $$(trans h) $$qa ||]+checkToken farExp p ok = ok+  { unGen = \ctx -> [||+    let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in+    if $$(genCode p) c+    then $$(unGen ok ctx+      { valueStack = ValueStackCons (H.Term [||c||]) (valueStack ctx)+      , input = [||cs||]+      })+    else let _ = "checkToken.else" in $$(unGen (fail farExp) ctx)+    ||]+  } -liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c-liftCode2 p a b = case p of-  InstrPureSameOffset -> [|| $$sameOffset $$a $$b ||]-  InstrPureHaskell h -> go a b h-  where-  go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c-  go qa qb = \case-    (H.:$) -> [|| $$qa $$qb ||]-    (H.:.) -> [|| \x -> $$qa ($$qb x) ||]-    H.Flip -> [|| \x -> $$qa x $$qb ||]-    H.Flip H.:@ H.Const -> [|| $$qb ||]-    H.Flip H.:@ f -> go qb qa f-    H.Const -> [|| $$qa ||]-    H.Cons -> [|| $$qa : $$qb ||]-    h -> [|| $$(trans h) $$qa $$qb ||]

@@ -35,7 +35,7 @@   compareOffset = [|| compare `on` offset ||]   lowerOffset :: CodeQ (cur -> cur -> Bool)   sameOffset :: CodeQ (cur -> cur -> Bool)-  shiftRight :: CodeQ (cur -> Int -> cur)+  shiftRight :: CodeQ (Int -> cur -> cur) instance Cursorable Int where   offset = \inp -> inp   compareOffset = [|| compare @Int ||]@@ -48,22 +48,25 @@   sameOffset = [|| \(Text _ i _) (Text _ j _) -> i == j ||]   shiftRight = [||shiftRightText||] -shiftRightText :: Text -> Int -> Text-shiftRightText (Text arr off unconsumed) i = go i off unconsumed+shiftRightText :: Int -> Text -> Text+shiftRightText i (Text arr off unconsumed) = go i off unconsumed   where-    go 0 off' unconsumed' = Text arr off' unconsumed'-    go n off' unconsumed'-      | unconsumed' > 0 = let !d = iter_ (Text arr off' unconsumed') 0-                          in go (n-1) (off'+d) (unconsumed'-d)-      | otherwise = Text arr off' unconsumed'+  go 0 off' unconsumed' = Text arr off' unconsumed'+  go n off' unconsumed'+    | unconsumed' > 0+    , !d <- iter_ (Text arr off' unconsumed') 0+    = go (n-1) (off'+d) (unconsumed'-d)+    | otherwise = Text arr off' unconsumed' -shiftLeftText :: Text -> Int -> Text-shiftLeftText (Text arr off unconsumed) i = go i off unconsumed+shiftLeftText :: Int -> Text -> Text+shiftLeftText i (Text arr off unconsumed) = go i off unconsumed   where-    go 0 off' unconsumed' = Text arr off' unconsumed'-    go n off' unconsumed'-      | off' > 0 = let !d = reverseIter_ (Text arr off' unconsumed') 0 in go (n-1) (off'+d) (unconsumed'-d)-      | otherwise = Text arr off' unconsumed'+  go 0 off' unconsumed' = Text arr off' unconsumed'+  go n off' unconsumed'+    | off' > 0+    , !d <- reverseIter_ (Text arr off' unconsumed') 0+    = go (n-1) (off'+d) (unconsumed'-d)+    | otherwise = Text arr off' unconsumed'  instance Cursorable UnpackedLazyByteString where   offset = \(UnpackedLazyByteString i _ _ _ _ _) -> i@@ -71,15 +74,17 @@   sameOffset = [||\(UnpackedLazyByteString i _ _ _ _ _) (UnpackedLazyByteString j _ _ _ _ _) -> i == j||]   shiftRight = [||shiftRightByteString||] -shiftRightByteString :: UnpackedLazyByteString -> Int -> UnpackedLazyByteString-shiftRightByteString !(UnpackedLazyByteString i addr# final off size cs) j+shiftRightByteString :: Int -> UnpackedLazyByteString -> UnpackedLazyByteString+shiftRightByteString j !(UnpackedLazyByteString i addr# final off size cs)   | j < size  = UnpackedLazyByteString (i + j) addr# final (off + j) (size - j) cs   | otherwise = case cs of-    BSL.Chunk (PS (ForeignPtr addr'# final') off' size') cs' -> shiftRightByteString (UnpackedLazyByteString (i + size) addr'# final' off' size' cs') (j - size)+    BSL.Chunk (PS (ForeignPtr addr'# final') off' size') cs' ->+      shiftRightByteString (j - size)+        (UnpackedLazyByteString (i + size) addr'# final' off' size' cs')     BSL.Empty -> emptyUnpackedLazyByteString (i + size) -shiftLeftByteString :: UnpackedLazyByteString -> Int -> UnpackedLazyByteString-shiftLeftByteString (UnpackedLazyByteString i addr# final off size cs) j =+shiftLeftByteString :: Int -> UnpackedLazyByteString -> UnpackedLazyByteString+shiftLeftByteString j (UnpackedLazyByteString i addr# final off size cs) =   UnpackedLazyByteString (i - d) addr# final (off - d) (size + d) cs   where d = min off j @@ -99,7 +104,7 @@ instance Cursorable (OffWith Stream) where   lowerOffset = [|| \(OffWith i _) (OffWith j _) -> i < j ||]   sameOffset = [|| \(OffWith i _) (OffWith j _) -> i == j ||]-  shiftRight = [|| \(OffWith o ts) i -> OffWith (o + i) (dropStream i ts) ||]+  shiftRight = [|| \i (OffWith o ts) -> OffWith (o + i) (dropStream i ts) ||]   where     dropStream :: Int -> Stream -> Stream     dropStream 0 cs = cs@@ -114,7 +119,7 @@   offset = \(OffWith i _) -> i   lowerOffset = [|| \(OffWith i _) (OffWith j _) -> i < j ||]   sameOffset = [|| \(OffWith i _) (OffWith j _) -> i == j ||]-  shiftRight = [|| \(OffWith o ts) i -> OffWith (o + i) (List.drop i ts) ||]+  shiftRight = [|| \i (OffWith o ts) -> OffWith (o + i) (List.drop i ts) ||]  -- ** Type 'OffWithStreamAnd' data OffWithStreamAnd ts = OffWithStreamAnd {-# UNPACK #-} !Int !Stream ts@@ -194,13 +199,15 @@                   (# C# (chr# (word2Int# x))                   , if size /= 1 then UnpackedLazyByteString (i+1) addr# final (off+1) (size-1) cs                     else case cs of-                      BSL.Chunk (PS (ForeignPtr addr'# final') off' size') cs' -> UnpackedLazyByteString (i+1) addr'# final' off' size' cs'+                      BSL.Chunk (PS (ForeignPtr addr'# final') off' size') cs' ->+                        UnpackedLazyByteString (i+1) addr'# final' off' size' cs'                       BSL.Empty -> emptyUnpackedLazyByteString (i+1)                   #)           more (UnpackedLazyByteString _ _ _ _ 0 _) = False           more _ = True           init = case $$qinput of-            BSL.Chunk (PS (ForeignPtr addr# final) off size) cs -> UnpackedLazyByteString 0 addr# final off size cs+            BSL.Chunk (PS (ForeignPtr addr# final) off size) cs ->+              UnpackedLazyByteString 0 addr# final off size cs             BSL.Empty -> emptyUnpackedLazyByteString 0       in (# init, more, next #)     ||]

@@ -1,407 +1,155 @@-{-# LANGUAGE ConstraintKinds #-} -- For Executable+{-# LANGUAGE ConstraintKinds #-} -- For Machine {-# LANGUAGE DerivingStrategies #-} -- For Show (LetName a)-{-# LANGUAGE PatternSynonyms #-} -- For Fmap, App, …-{-# LANGUAGE UndecidableInstances #-} -- For Cursorable (Cursor inp)+-- | Semantic of the parsing instructions used+-- to make the parsing control-flow explicit,+-- in the convenient tagless-final encoding. module Symantic.Parser.Machine.Instructions where  import Data.Bool (Bool(..)) import Data.Either (Either)-import Data.Eq (Eq)-import Data.Ord (Ord)-import Data.Function (($), (.))+import Data.Eq (Eq(..))+import Data.Function ((.)) import Data.Kind (Type)-import System.IO.Unsafe (unsafePerformIO)-import Text.Show (Show(..), showString)-import qualified Data.Functor as Functor+-- import GHC.TypeLits (Symbol)+import Text.Show (Show(..)) import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Syntax as TH import qualified Symantic.Parser.Haskell as H  import Symantic.Parser.Grammar import Symantic.Parser.Machine.Input-import Symantic.Univariant.Trans --- * Type 'Instr'--- | 'Instr'uctions for the 'Machine'.-data Instr input valueStack (failStack::Peano) returnValue where-  -- | @('Push' x k)@ pushes @(x)@ on the 'valueStack'-  -- and continues with the next 'Instr'uction @(k)@.-  Push ::-    InstrPure v ->-    Instr inp (v ': vs) es ret ->-    Instr inp vs es ret-  -- | @('Pop' k)@ pushes @(x)@ on the 'valueStack'.-  Pop ::-    Instr inp vs es ret ->-    Instr inp (v ': vs) es ret-  -- | @('LiftI2' f k)@ pops two values from the 'valueStack',-  -- and pushes the result of @(f)@ applied to them.-  LiftI2 ::-    InstrPure (x -> y -> z) ->-    Instr inp (z : vs) es ret ->-    Instr inp (y : x : vs) es ret-  -- | @('Fail')@ raises an error from the 'failStack'.-  Fail ::-    [ErrorItem (InputToken inp)] ->-    Instr inp vs ('Succ es) ret-  -- | @('PopFail' k)@ removes a 'FailHandler' from the 'failStack'-  -- and continues with the next 'Instr'uction @(k)@.-  PopFail ::-    Instr inp vs es ret ->-    Instr inp vs ('Succ es) ret-  -- | @('CatchFail' l r)@ tries the @(l)@ 'Instr'uction-  -- in a new failure scope such that if @(l)@ raises a failure, it is caught,-  -- then the input is pushed as it was before trying @(l)@ on the 'valueStack',-  -- and the control flow goes on with the @(r)@ 'Instr'uction.-  CatchFail ::-    Instr inp vs ('Succ es) ret ->-    Instr inp (Cursor inp ': vs) es ret ->-    Instr inp vs es ret-  -- | @('LoadInput' k)@ removes the input from the 'valueStack'-  -- and continues with the next 'Instr'uction @(k)@ using that input.-  LoadInput ::-    Instr inp vs es r ->-    Instr inp (Cursor inp : vs) es r-  -- | @('PushInput' k)@ pushes the input @(inp)@ on the 'valueStack'-  -- and continues with the next 'Instr'uction @(k)@.-  PushInput ::-    Instr inp (Cursor inp ': vs) es ret ->-    Instr inp vs es ret-  -- | @('Case' l r)@.-  Case ::-    Instr inp (x ': vs) es r ->-    Instr inp (y ': vs) es r ->-    Instr inp (Either x y ': vs) es r-  -- | @('Swap' k)@ pops two values on the 'valueStack',-  -- pushes the first popped-out, then the second,-  -- and continues with the next 'Instr'uction @(k)@.-  Swap ::-    Instr inp (x ': y ': vs) es r ->-    Instr inp (y ': x ': vs) es r-  -- | @('Choices' ps bs d)@.-  Choices ::-    [InstrPure (v -> Bool)] ->-    [Instr inp vs es ret] ->-    Instr inp vs es ret ->-    Instr inp (v ': vs) es ret-  -- | @('Subroutine' n v k)@ binds the 'LetName' @(n)@ to the 'Instr'uction's @(v)@,-  -- 'Call's @(n)@ and-  -- continues with the next 'Instr'uction @(k)@.-  Subroutine ::-    LetName v -> Instr inp '[] ('Succ 'Zero) v ->-    Instr inp vs ('Succ es) ret ->-    Instr inp vs ('Succ es) ret-  -- | @('Jump' n k)@ pass the control-flow to the 'Subroutine' named @(n)@.-  Jump ::-    LetName ret ->-    Instr inp '[] ('Succ es) ret-  -- | @('Call' n k)@ pass the control-flow to the 'Subroutine' named @(n)@,-  -- and when it 'Ret'urns, continues with the next 'Instr'uction @(k)@.-  Call ::-    LetName v ->-    Instr inp (v ': vs) ('Succ es) ret ->-    Instr inp vs ('Succ es) ret-  -- | @('Ret')@ returns the value stored in a singleton 'valueStack'.-  Ret ::-    Instr inp '[ret] es ret-  -- | @('Read' expected p k)@ reads a 'Char' @(c)@ from the 'inp'ut,-  -- if @(p c)@ is 'True' then continues with the next 'Instr'uction @(k)@ on,-  -- otherwise 'Fail'.-  Read ::-    [ErrorItem (InputToken inp)] ->-    InstrPure (InputToken inp -> Bool) ->-    Instr inp (InputToken inp ': vs) ('Succ es) ret ->-    Instr inp vs ('Succ es) ret-  DefJoin ::-    LetName v -> Instr inp (v ': vs) es ret ->-    Instr inp vs es ret ->-    Instr inp vs es ret-  RefJoin ::-    LetName v ->-    Instr inp (v ': vs) es ret---- ** Type 'InstrPure'-data InstrPure a where-  InstrPureHaskell :: H.Haskell a -> InstrPure a-  InstrPureSameOffset :: Cursorable cur => InstrPure (cur -> cur -> Bool)--instance Show (InstrPure a) where-  showsPrec p = \case-    InstrPureHaskell x -> showsPrec p x-    InstrPureSameOffset -> showString "InstrPureSameOffset"-instance Trans InstrPure TH.CodeQ where-  trans = \case-    InstrPureHaskell x -> trans x-    InstrPureSameOffset -> sameOffset+-- * Type 'TermInstr'+type TermInstr = H.Term TH.CodeQ --- ** Type 'LetName'-newtype LetName a = LetName { unLetName :: TH.Name }-  deriving (Eq)-  deriving newtype Show+-- * Type 'Peano'+-- | Type-level natural numbers,+-- using the Peano recursive encoding.+data Peano = Zero | Succ Peano --- * Class 'Executable'-type Executable repr =-  ( Stackable repr-  , Branchable repr+-- * Class 'Machine'+-- | All the 'Instr'uctions.+type Machine tok repr =+  ( Branchable repr   , Failable repr   , Inputable repr-  , Routinable repr   , Joinable repr+  , Routinable repr+  , Stackable repr+  , Readable tok repr   ) +-- ** Type 'ReprInstr'+type ReprInstr = Type -> [Type] -> Peano -> Type -> Type++-- ** Type 'LetName'+-- | 'TH.Name' of a 'subroutine' or 'defJoin'+-- indexed by the return type of the factorized 'Instr'uctions.+-- This helps type-inferencing.+newtype LetName a = LetName { unLetName :: TH.Name }+  deriving Eq+  deriving newtype Show+ -- ** Class 'Stackable'-class Stackable (repr :: Type -> [Type] -> Peano -> Type -> Type) where+class Stackable (repr::ReprInstr) where   push ::-    InstrPure v ->-    repr inp (v ': vs) n ret ->-    repr inp vs n ret+    TermInstr v ->+    repr inp (v ': vs) es a ->+    repr inp vs es a   pop ::-    repr inp vs n ret ->-    repr inp (v ': vs) n ret+    repr inp vs es a ->+    repr inp (v ': vs) es a   liftI2 ::-    InstrPure (x -> y -> z) ->-    repr inp (z ': vs) es ret ->-    repr inp (y ': x ': vs) es ret+    TermInstr (x -> y -> z) ->+    repr inp (z ': vs) es a ->+    repr inp (y ': x ': vs) es a   swap ::-    repr inp (x ': y ': vs) n r ->-    repr inp (y ': x ': vs) n r+    repr inp (x ': y ': vs) es a ->+    repr inp (y ': x ': vs) es a+  -- | @('mapI' f k)@.+  mapI ::+    TermInstr (x -> y) ->+    repr inp (y ': vs) es a ->+    repr inp (x ': vs) es a+  mapI f = push f . liftI2 (H.flip H..@ (H.$))+  -- | @('appI' k)@ pops @(x)@ and @(x2y)@ from the 'valueStack',+  -- pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.+  appI ::+    repr inp (y ': vs) es a ->+    repr inp (x ': (x -> y) ': vs) es a+  appI = liftI2 (H.$) +-- ** Class 'Routinable'+class Routinable (repr::ReprInstr) where+  subroutine ::+    LetName v -> repr inp '[] ('Succ 'Zero) v ->+    repr inp vs ('Succ es) a ->+    repr inp vs ('Succ es) a+  call ::+    LetName v -> repr inp (v ': vs) ('Succ es) a ->+    repr inp vs ('Succ es) a+  ret ::+    repr inp '[a] es a+  jump ::+    LetName a ->+    repr inp '[] ('Succ es) a+ -- ** Class 'Branchable'-class Branchable (repr :: Type -> [Type] -> Peano -> Type -> Type) where-  case_ ::-    repr inp (x ': vs) n r ->-    repr inp (y ': vs) n r ->-    repr inp (Either x y ': vs) n r+class Branchable (repr::ReprInstr) where+  caseI ::+    repr inp (x ': vs) es r ->+    repr inp (y ': vs) es r ->+    repr inp (Either x y ': vs) es r   choices ::-    [InstrPure (v -> Bool)] ->-    [repr inp vs es ret] ->-    repr inp vs es ret ->-    repr inp (v ': vs) es ret+    [TermInstr (v -> Bool)] ->+    [repr inp vs es a] ->+    repr inp vs es a ->+    repr inp (v ': vs) es a+  -- | @('ifI' ok ko)@ pops a 'Bool' from the 'valueStack'+  -- and continues either with the 'Instr'uction @(ok)@ if it is 'True'+  -- or @(ko)@ otherwise.+  ifI ::+    repr inp vs es a ->+    repr inp vs es a ->+    repr inp (Bool ': vs) es a+  ifI ok ko = choices [H.id] [ok] ko  -- ** Class 'Failable'-class Failable (repr :: Type -> [Type] -> Peano -> Type -> Type) where-  fail :: [ErrorItem (InputToken inp)] -> repr inp vs ('Succ es) ret+class Failable (repr::ReprInstr) where+  fail ::+    [ErrorItem (InputToken inp)] ->+    repr inp vs ('Succ es) a   popFail ::-    repr inp vs es ret ->-    repr inp vs ('Succ es) ret+    repr inp vs es a ->+    repr inp vs ('Succ es) a   catchFail ::-    repr inp vs ('Succ es) ret ->-    repr inp (Cursor inp ': vs) es ret ->-    repr inp vs es ret+    repr inp vs ('Succ es) a ->+    repr inp (Cursor inp ': vs) es a ->+    repr inp vs es a  -- ** Class 'Inputable'-class Inputable (repr :: Type -> [Type] -> Peano -> Type -> Type) where+class Inputable (repr::ReprInstr) where   loadInput ::-    repr inp vs es r ->-    repr inp (Cursor inp ': vs) es r+    repr inp vs es a ->+    repr inp (Cursor inp ': vs) es a   pushInput ::-    repr inp (Cursor inp ': vs) es ret ->-    repr inp vs es ret---- ** Class 'Routinable'-class Routinable (repr :: Type -> [Type] -> Peano -> Type -> Type) where-  subroutine ::-    LetName v -> repr inp '[] ('Succ 'Zero) v ->-    repr inp vs ('Succ es) ret ->-    repr inp vs ('Succ es) ret-  call ::-    LetName v -> repr inp (v ': vs) ('Succ es) ret ->-    repr inp vs ('Succ es) ret-  ret ::-    repr inp '[ret] es ret-  jump ::-    LetName ret ->-    repr inp '[] ('Succ es) ret+    repr inp (Cursor inp ': vs) es a ->+    repr inp vs es a  -- ** Class 'Joinable'-class Joinable (repr :: Type -> [Type] -> Peano -> Type -> Type) where+class Joinable (repr::ReprInstr) where   defJoin ::-    LetName v ->-    repr inp (v ': vs) es ret ->-    repr inp vs es ret ->-    repr inp vs es ret+    LetName v -> repr inp (v ': vs) es a ->+    repr inp vs es a ->+    repr inp vs es a   refJoin ::     LetName v ->-    repr inp (v ': vs) es ret+    repr inp (v ': vs) es a  -- ** Class 'Readable'-class Readable (repr :: Type -> [Type] -> Peano -> Type -> Type) (tok::Type) where+class Readable (tok::Type) (repr::ReprInstr) where   read ::     tok ~ InputToken inp =>     [ErrorItem tok] ->-    InstrPure (tok -> Bool) ->-    repr inp (tok ': vs) ('Succ es) ret ->-    repr inp vs ('Succ es) ret--instance-  ( Executable repr-  , Readable repr (InputToken inp)-  ) => Trans (Instr inp vs es) (repr inp vs es) where-  trans = \case-    Push x k -> push x (trans k)-    Pop k -> pop (trans k)-    LiftI2 f k -> liftI2 f (trans k)-    Fail err -> fail err-    PopFail k -> popFail (trans k)-    CatchFail l r -> catchFail (trans l) (trans r)-    LoadInput k -> loadInput (trans k)-    PushInput k -> pushInput (trans k)-    Case l r -> case_ (trans l) (trans r)-    Swap k -> swap (trans k)-    Choices ps bs d -> choices ps (trans Functor.<$> bs) (trans d)-    Subroutine n sub k -> subroutine n (trans sub) (trans k)-    Jump n -> jump n-    Call n k -> call n (trans k)-    Ret -> ret-    Read es p k -> read es p (trans k)-    DefJoin n sub k -> defJoin n (trans sub) (trans k)-    RefJoin n -> refJoin n---- ** Type 'Peano'--- | Type-level natural numbers, using the Peano recursive encoding.-data Peano = Zero | Succ Peano---- | @('Fmap' f k)@.-pattern Fmap ::-  InstrPure (x -> y) ->-  Instr inp (y ': xs) es ret ->-  Instr inp (x ': xs) es ret-pattern Fmap f k = Push f (LiftI2 (InstrPureHaskell (H.Flip H.:@ (H.:$))) k)---- | @('App' k)@ pops @(x)@ and @(x2y)@ from the 'valueStack',--- pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.-pattern App ::-  Instr inp (y : vs) es ret ->-  Instr inp (x : (x -> y) : vs) es ret-pattern App k = LiftI2 (InstrPureHaskell (H.:$)) k---- | @('If' ok ko)@ pops a 'Bool' from the 'valueStack'--- and continues either with the 'Instr'uction @(ok)@ if it is 'True'--- or @(ko)@ otherwise.-pattern If ::-  Instr inp vs es ret ->-  Instr inp vs es ret ->-  Instr inp (Bool ': vs) es ret-pattern If ok ko = Choices [InstrPureHaskell H.Id] [ok] ko---- * Type 'Machine'--- | Making the control-flow explicit.-data Machine inp v = Machine { unMachine ::-  forall vs es ret.-  {-k-}Instr inp (v ': vs) ('Succ es) ret ->-  Instr inp vs ('Succ es) ret-  }--runMachine ::-  forall inp v es repr.-  Executable repr =>-  Readable repr (InputToken inp) =>-  Machine inp v -> repr inp '[] ('Succ es) v-runMachine (Machine auto) =-  trans @(Instr inp '[] ('Succ es)) $-  auto Ret--instance Applicable (Machine inp) where-  pure x = Machine $ Push (InstrPureHaskell x)-  Machine f <*> Machine x = Machine $ f . x . App-  liftA2 f (Machine x) (Machine y) = Machine $-    x . y . LiftI2 (InstrPureHaskell f)-  Machine x *> Machine y = Machine $ x . Pop . y-  Machine x <* Machine y = Machine $ x . y . Pop-instance-  Cursorable (Cursor inp) =>-  Alternable (Machine inp) where-  empty = Machine $ \_k -> Fail []-  Machine l <|> Machine r = Machine $ \k ->-    makeJoin k $ \j ->-    CatchFail-      (l (PopFail j))-      (failIfConsumed (r j))-  try (Machine x) = Machine $ \k ->-    CatchFail (x (PopFail k))-      -- On exception, reset the input,-      -- and propagate the failure.-      (LoadInput (Fail []))---- | If no input has been consumed by the failing alternative--- then continue with the given continuation.--- Otherwise, propagate the 'Fail'ure.-failIfConsumed ::-  Cursorable (Cursor inp) =>-  Instr inp vs ('Succ es) ret ->-  Instr inp (Cursor inp : vs) ('Succ es) ret-failIfConsumed k = PushInput (LiftI2 InstrPureSameOffset (If k (Fail [])))---- | @('makeJoin' k f)@ factorizes @(k)@ in @(f)@,--- by introducing a 'DefJoin' if necessary,--- and passing the corresponding 'RefJoin' to @(f)@,--- or @(k)@ as is when factorizing is useless.-makeJoin ::-  Instr inp (v : vs) es ret ->-  (Instr inp (v : vs) es ret -> Instr inp vs es ret) ->-  Instr inp vs es ret--- Double RefJoin Optimization:--- If a join-node points directly to another join-node,--- then reuse it-makeJoin k@RefJoin{} = ($ k)--- Terminal RefJoin Optimization:--- If a join-node points directly to a terminal operation,--- then it's useless to introduce a join-point.-makeJoin k@Ret = ($ k)-makeJoin k =-  let joinName = LetName $ unsafePerformIO $ TH.qNewName "join" in-  \f -> DefJoin joinName k (f (RefJoin joinName))--instance tok ~ InputToken inp => Satisfiable (Machine inp) tok where-  satisfy es p = Machine $ Read es (InstrPureHaskell p)-instance Selectable (Machine inp) where-  branch (Machine lr) (Machine l) (Machine r) = Machine $ \k ->-    makeJoin k $ \j ->-    lr (Case (l (Swap (App j)))-             (r (Swap (App j))))-instance Matchable (Machine inp) where-  conditional ps bs (Machine m) (Machine default_) = Machine $ \k ->-    makeJoin k $ \j ->-    m (Choices (InstrPureHaskell Functor.<$> ps)-               ((\b -> unMachine b j) Functor.<$> bs)-               (default_ j))-instance-  ( Ord (InputToken inp)-  , Cursorable (Cursor inp)-  ) => Lookable (Machine inp) where-  look (Machine x) = Machine $ \k ->-    PushInput (x (Swap (LoadInput k)))-  eof = negLook (satisfy [{-discarded by negLook-}] (H.const H..@ H.bool True))-        -- Set a better failure message-        <|> (Machine $ \_k -> Fail [ErrorItemEnd])-  negLook (Machine x) = Machine $ \k ->-    CatchFail-      -- On x success, discard the result,-      -- and replace this 'CatchFail''s failure handler-      -- by a 'Fail'ure whose 'farthestExpecting' is negated,-      -- then a failure is raised from the input-      -- when entering 'negLook', to avoid odd cases:-      -- - where the failure that made (negLook x)-      --   succeed can get the blame for the overall-      --   failure of the grammar.-      -- - where the overall failure of-      --   the grammar might be blamed on something in x-      --   that, if corrected, still makes x succeed and-      --   (negLook x) fail.-      (PushInput (x (Pop (PopFail (LoadInput (Fail []))))))-      -- On x failure, reset the input,-      -- and go on with the next 'Instr'uctions.-      (LoadInput (Push (InstrPureHaskell H.unit) k))-instance Letable TH.Name (Machine inp) where-  def n v = Machine $ \k ->-    Subroutine (LetName n) (unMachine v Ret) (Call (LetName n) k)-  ref _isRec n = Machine $ \case-    Ret -> Jump (LetName n)-    k -> Call (LetName n) k-instance Cursorable (Cursor inp) => Foldable (Machine inp) where-  {--  chainPre op p = go <*> p-    where go = (H..) <$> op <*> go <|> pure H.id-  chainPost p op = p <**> go-    where go = (H..) <$> op <*> go <|> pure H.id-  -}+    TermInstr (tok -> Bool) ->+    repr inp (tok ': vs) ('Succ es) a ->+    repr inp vs ('Succ es) a

@@ -0,0 +1,249 @@+{-# LANGUAGE PatternSynonyms #-} -- For Instr+{-# LANGUAGE ViewPatterns #-} -- For unSomeInstr+{-# LANGUAGE UndecidableInstances #-}+-- | Initial encoding with bottom-up optimizations of 'Instr'uctions,+-- re-optimizing downward as needed after each optimization.+-- There is only one optimization (for 'push') so far,+-- but the introspection enabled by the 'Instr' data-type+-- is also useful to optimize with more context in the 'Machine'.+module Symantic.Parser.Machine.Optimize where++import Data.Bool (Bool(..))+import Data.Either (Either)+import Data.Maybe (Maybe(..))+import Data.Function ((.))+import Data.Kind (Constraint)+import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))+import qualified Data.Functor as Functor++import Symantic.Parser.Grammar+import Symantic.Parser.Machine.Input+import Symantic.Parser.Machine.Instructions+import Symantic.Univariant.Trans++-- * Data family 'Instr'+-- | 'Instr'uctions of the 'Machine'.+-- This is an extensible data-type.+data family Instr+  (instr :: ReprInstr -> Constraint)+  (repr :: ReprInstr)+  :: ReprInstr++-- | Convenient utility to pattern-match a 'SomeInstr'.+pattern Instr :: Typeable comb =>+  Instr comb repr inp vs es a ->+  SomeInstr repr inp vs es a+pattern Instr x <- (unSomeInstr -> Just x)++-- ** Type 'SomeInstr'+-- | Some 'Instr'uction existantialized over the actual instruction symantic class.+-- Useful to handle a list of 'Instr'uctions+-- without requiring impredicative quantification.+-- Must be used by pattern-matching+-- on the 'SomeInstr' data-constructor,+-- to bring the constraints in scope.+--+-- As in 'SomeComb', a first pass of optimizations+-- is directly applied in it+-- to avoid introducing an extra newtype,+-- this also give a more comprehensible code.+data SomeInstr repr inp vs es a =+  forall instr.+  (Trans (Instr instr repr inp vs es) (repr inp vs es), Typeable instr) =>+  SomeInstr (Instr instr repr inp vs es a)++instance Trans (SomeInstr repr inp vs es) (repr inp vs es) where+  trans (SomeInstr x) = trans x++-- | @(unSomeInstr i :: 'Maybe' ('Instr' comb repr inp vs es a))@+-- extract the data-constructor from the given 'SomeInstr'+-- iif. it belongs to the @('Instr' comb repr a)@ data-instance.+unSomeInstr ::+  forall instr repr inp vs es a.+  Typeable instr =>+  SomeInstr repr inp vs es a ->+  Maybe (Instr instr repr inp vs es a)+unSomeInstr (SomeInstr (i::Instr i repr inp vs es a)) =+  case typeRep @instr `eqTypeRep` typeRep @i of+    Just HRefl -> Just i+    Nothing -> Nothing++-- Stackable+data instance Instr Stackable repr inp vs fs a where+  -- | @('Push' x k)@ pushes @(x)@ on the 'valueStack'+  -- and continues with the next 'Instr'uction @(k)@.+  Push ::+    TermInstr v ->+    SomeInstr repr inp (v ': vs) es a ->+    Instr Stackable repr inp vs es a+  -- | @('Pop' k)@ pushes @(x)@ on the 'valueStack'.+  Pop ::+    SomeInstr repr inp vs es a ->+    Instr Stackable repr inp (v ': vs) es a+  -- | @('LiftI2' f k)@ pops two values from the 'valueStack',+  -- and pushes the result of @(f)@ applied to them.+  LiftI2 ::+    TermInstr (x -> y -> z) ->+    SomeInstr repr inp (z : vs) es a ->+    Instr Stackable repr inp (y : x : vs) es a+  -- | @('Swap' k)@ pops two values on the 'valueStack',+  -- pushes the first popped-out, then the second,+  -- and continues with the next 'Instr'uction @(k)@.+  Swap ::+    SomeInstr repr inp (x ': y ': vs) es a ->+    Instr Stackable repr inp (y ': x ': vs) es a+instance Stackable repr => Trans (Instr Stackable repr inp vs es) (repr inp vs es) where+  trans = \case+    Push x k -> push x (trans k)+    Pop k -> pop (trans k)+    LiftI2 f k -> liftI2 f (trans k)+    Swap k -> swap (trans k)+instance Stackable repr => Stackable (SomeInstr repr) where+  push _v (Instr (Pop i)) = i+  push v i = SomeInstr (Push v i)+  pop = SomeInstr . Pop+  liftI2 f = SomeInstr . LiftI2 f+  swap = SomeInstr . Swap++-- Routinable+data instance Instr Routinable repr inp vs fs a where+  -- | @('Subroutine' n v k)@ binds the 'LetName' @(n)@ to the 'Instr'uction's @(v)@,+  -- 'Call's @(n)@ and+  -- continues with the next 'Instr'uction @(k)@.+  Subroutine ::+    LetName v ->+    SomeInstr repr inp '[] ('Succ 'Zero) v ->+    SomeInstr repr inp vs ('Succ es) a ->+    Instr Routinable repr inp vs ('Succ es) a+  -- | @('Jump' n k)@ pass the control-flow to the 'Subroutine' named @(n)@.+  Jump ::+    LetName a ->+    Instr Routinable repr inp '[] ('Succ es) a+  -- | @('Call' n k)@ pass the control-flow to the 'Subroutine' named @(n)@,+  -- and when it 'Ret'urns, continues with the next 'Instr'uction @(k)@.+  Call ::+    LetName v ->+    SomeInstr repr inp (v ': vs) ('Succ es) a ->+    Instr Routinable repr inp vs ('Succ es) a+  -- | @('Ret')@ returns the value stored in a singleton 'valueStack'.+  Ret ::+    Instr Routinable repr inp '[a] es a+instance Routinable repr => Trans (Instr Routinable repr inp vs es) (repr inp vs es) where+  trans = \case+    Subroutine n sub k -> subroutine n (trans sub) (trans k)+    Jump n -> jump n+    Call n k -> call n (trans k)+    Ret -> ret+instance Routinable repr => Routinable (SomeInstr repr) where+  subroutine n sub = SomeInstr . Subroutine n sub+  jump = SomeInstr . Jump+  call n = SomeInstr . Call n+  ret = SomeInstr Ret++-- Branchable+data instance Instr Branchable repr inp vs fs a where+  -- | @('Case' l r)@.+  Case ::+    SomeInstr repr inp (x ': vs) es a ->+    SomeInstr repr inp (y ': vs) es a ->+    Instr Branchable repr inp (Either x y ': vs) es a+  -- | @('Choices' ps bs d)@.+  Choices ::+    [TermInstr (v -> Bool)] ->+    [SomeInstr repr inp vs es a] ->+    SomeInstr repr inp vs es a ->+    Instr Branchable repr inp (v ': vs) es a+instance Branchable repr => Trans (Instr Branchable repr inp vs es) (repr inp vs es) where+  trans = \case+    Case l r -> caseI (trans l) (trans r)+    Choices ps bs d -> choices ps (trans Functor.<$> bs) (trans d)+instance Branchable repr => Branchable (SomeInstr repr) where+  caseI l = SomeInstr . Case l+  choices ps bs = SomeInstr . Choices ps bs++-- Failable+data instance Instr Failable repr inp vs fs a where+  -- | @('Fail')@ raises an error from the 'failStack'.+  Fail ::+    [ErrorItem (InputToken inp)] ->+    Instr Failable repr inp vs ('Succ es) a+  -- | @('PopFail' k)@ removes a 'FailHandler' from the 'failStack'+  -- and continues with the next 'Instr'uction @(k)@.+  PopFail ::+    SomeInstr repr inp vs es ret ->+    Instr Failable repr inp vs ('Succ es) ret+  -- | @('CatchFail' l r)@ tries the @(l)@ 'Instr'uction+  -- in a new failure scope such that if @(l)@ raises a failure, it is caught,+  -- then the input is pushed as it was before trying @(l)@ on the 'valueStack',+  -- and the control flow goes on with the @(r)@ 'Instr'uction.+  CatchFail ::+    SomeInstr repr inp vs ('Succ es) ret ->+    SomeInstr repr inp (Cursor inp ': vs) es ret ->+    Instr Failable repr inp vs es ret+instance Failable repr => Trans (Instr Failable repr inp vs es) (repr inp vs es) where+  trans = \case+    Fail err -> fail err+    PopFail k -> popFail (trans k)+    CatchFail l r -> catchFail (trans l) (trans r)+instance Failable repr => Failable (SomeInstr repr) where+  fail = SomeInstr . Fail+  popFail = SomeInstr . PopFail+  catchFail x = SomeInstr . CatchFail x++-- Inputable+data instance Instr Inputable repr inp vs fs a where+  -- | @('LoadInput' k)@ removes the input from the 'valueStack'+  -- and continues with the next 'Instr'uction @(k)@ using that input.+  LoadInput ::+    SomeInstr repr inp vs es a ->+    Instr Inputable repr inp (Cursor inp : vs) es a+  -- | @('PushInput' k)@ pushes the input @(inp)@ on the 'valueStack'+  -- and continues with the next 'Instr'uction @(k)@.+  PushInput ::+    SomeInstr repr inp (Cursor inp ': vs) es a ->+    Instr Inputable repr inp vs es a+instance Inputable repr => Trans (Instr Inputable repr inp vs es) (repr inp vs es) where+  trans = \case+    LoadInput k -> loadInput (trans k)+    PushInput k -> pushInput (trans k)+instance Inputable repr => Inputable (SomeInstr repr) where+  loadInput = SomeInstr . LoadInput+  pushInput = SomeInstr . PushInput++-- Joinable+data instance Instr Joinable repr inp vs fs a where+  DefJoin ::+    LetName v ->+    SomeInstr repr inp (v ': vs) es a ->+    SomeInstr repr inp vs es a ->+    Instr Joinable repr inp vs es a+  RefJoin ::+    LetName v ->+    Instr Joinable repr inp (v ': vs) es a+instance Joinable repr => Trans (Instr Joinable repr inp vs es) (repr inp vs es) where+  trans = \case+    DefJoin n sub k -> defJoin n (trans sub) (trans k)+    RefJoin n -> refJoin n+instance Joinable repr => Joinable (SomeInstr repr) where+  defJoin n sub = SomeInstr . DefJoin n sub+  refJoin = SomeInstr . RefJoin++-- Readable+data instance Instr (Readable tok) repr inp vs fs a where+  -- | @('Read' expected p k)@ reads a 'Char' @(c)@ from the 'inp'ut,+  -- if @(p c)@ is 'True' then continues with the next 'Instr'uction @(k)@ on,+  -- otherwise 'Fail'.+  Read ::+    [ErrorItem (InputToken inp)] ->+    TermInstr (InputToken inp -> Bool) ->+    SomeInstr repr inp (InputToken inp ': vs) ('Succ es) a ->+    Instr (Readable tok) repr inp vs ('Succ es) a+instance+  ( Readable tok repr, tok ~ InputToken inp ) =>+  Trans (Instr (Readable tok) repr inp vs es) (repr inp vs es) where+  trans = \case+    Read es p k -> read es p (trans k)+instance+  ( Readable tok repr, Typeable tok ) =>+  Readable tok (SomeInstr repr) where+  read es p = SomeInstr . Read es p

@@ -0,0 +1,196 @@+{-# LANGUAGE UndecidableInstances #-} -- For Cursorable (Cursor inp)+-- | Build the 'Instr'uction 'Program' of a 'Machine'+-- from the 'Comb'inators of a 'Grammar'.+-- 'Instr'uctions are kept introspectable+-- to enable more optimizations now possible because+-- of a broader knowledge of the 'Instr'uctions around+-- those generated (eg. by using 'joinNext').+module Symantic.Parser.Machine.Program where++import Data.Bool (Bool(..))+import Data.Ord (Ord)+import Data.Function (($), (.))+import Type.Reflection (Typeable)+import System.IO.Unsafe (unsafePerformIO)+import qualified Data.Functor as Functor+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH+import qualified Symantic.Parser.Haskell as H++import Symantic.Parser.Grammar+import Symantic.Parser.Machine.Input+import Symantic.Parser.Machine.Instructions+import Symantic.Parser.Machine.Optimize+import Symantic.Univariant.Trans++-- * Type 'Program'+-- | A 'Program' is a tree of 'Instr'uctions,+-- where each 'Instr'uction is built by a continuation+-- to be able to introspect, duplicate and/or change+-- the next 'Instr'uction.+data Program repr inp a = Program { unProgram ::+  forall vs es ret.+  -- This is the next instruction+  SomeInstr repr inp (a ': vs) ('Succ es) ret ->+  -- This is the current instruction+  SomeInstr repr inp vs ('Succ es) ret }++-- | Build an interpreter of the 'Program' of the given 'Machine'.+optimizeMachine ::+  forall inp es repr a.+  Machine (InputToken inp) repr =>+  Program repr inp a ->+  repr inp '[] ('Succ es) a+optimizeMachine (Program f) = trans (f @'[] @es ret)++instance+  Stackable repr =>+  Applicable (Program repr inp) where+  pure x = Program (push (trans x))+  Program f <*> Program x = Program (f . x . appI)+  liftA2 f (Program x) (Program y) =+    Program (x . y . liftI2 (trans f))+  Program x *> Program y = Program (x . pop . y)+  Program x <* Program y = Program (x . y . pop)+instance+  ( Cursorable (Cursor inp)+  , Branchable repr+  , Failable repr+  , Inputable repr+  , Joinable repr+  , Stackable repr+  ) => Alternable (Program repr inp) where+  empty = Program $ \_next -> fail []+  Program l <|> Program r = joinNext $ Program $ \next ->+    catchFail+      (l (popFail next))+      (failIfConsumed (r next))+  try (Program x) = Program $ \next ->+    catchFail+      (x (popFail next))+      -- On exception, reset the input,+      -- and propagate the failure.+      (loadInput (fail []))++-- | If no input has been consumed by the failing alternative+-- then continue with the given continuation.+-- Otherwise, propagate the 'Fail'ure.+failIfConsumed ::+  Cursorable (Cursor inp) =>+  Branchable repr =>+  Failable repr =>+  Inputable repr =>+  Stackable repr =>+  SomeInstr repr inp vs ('Succ es) ret ->+  SomeInstr repr inp (Cursor inp : vs) ('Succ es) ret+failIfConsumed k = pushInput (liftI2 (H.Term sameOffset) (ifI k (fail [])))++-- | @('joinNext' m)@ factorize the next 'Instr'uction+-- to be able to reuse it multiple times without duplication.+-- It does so by introducing a 'defJoin'+-- and passing the corresponding 'refJoin'+-- as next 'Instr'uction to @(m)@,+-- unless factorizing is useless because the next 'Instr'uction+-- is already a 'refJoin' or a 'ret'.+-- It should be used each time the next 'Instr'uction+-- is used multiple times.+joinNext ::+  Joinable repr =>+  Program repr inp v ->+  Program repr inp v+joinNext (Program m) = Program $ \case+  -- Double refJoin Optimization:+  -- If a join-node points directly to another join-node,+  -- then reuse it+  next@(Instr RefJoin{}) -> m next+  -- Terminal refJoin Optimization:+  -- If a join-node points directly to a terminal operation,+  -- then it's useless to introduce a join-node.+  next@(Instr Ret{}) -> m next+  -- Introduce a join-node.+  next -> defJoin joinName next (m (refJoin joinName))+    where joinName = LetName $ unsafePerformIO $ TH.qNewName "join"++instance+  ( tok ~ InputToken inp+  , Readable tok repr+  , Typeable tok+  ) => Satisfiable tok (Program repr inp) where+  satisfy es p = Program $ read es (trans p)+instance+  ( Branchable repr+  , Joinable repr+  , Stackable repr+  ) => Selectable (Program repr inp) where+  branch (Program lr) (Program l) (Program r) = joinNext $ Program $ \next ->+    lr (caseI+      (l (swap (appI next)))+      (r (swap (appI next))))+instance+  ( Branchable repr+  , Joinable repr+  ) => Matchable (Program repr inp) where+  conditional (Program a) ps bs (Program d) = joinNext $ Program $ \next ->+    a (choices+      (trans Functor.<$> ps)+      ((\(Program b) -> b next) Functor.<$> bs)+      (d next))+instance+  ( Ord (InputToken inp)+  , Cursorable (Cursor inp)+  , Branchable repr+  , Failable repr+  , Inputable repr+  , Joinable repr+  , Readable (InputToken inp) repr+  , Typeable (InputToken inp)+  , Stackable repr+  ) => Lookable (Program repr inp) where+  look (Program x) = Program $ \next ->+    pushInput (x (swap (loadInput next)))+  eof = negLook (satisfy [{-discarded by negLook-}] (H.lam1 (\_x -> H.bool True)))+        -- This sets a better failure message+        <|> (Program $ \_k -> fail [ErrorItemEnd])+  negLook (Program x) = Program $ \next ->+    catchFail+      -- On x success, discard the result,+      -- and replace this 'CatchFail''s failure handler+      -- by a 'Fail'ure whose 'farthestExpecting' is negated,+      -- then a failure is raised from the input+      -- when entering 'negLook', to avoid odd cases:+      -- - where the failure that made (negLook x)+      --   succeed can get the blame for the overall+      --   failure of the grammar.+      -- - where the overall failure of+      --   the grammar might be blamed on something in x+      --   that, if corrected, still makes x succeed and+      --   (negLook x) fail.+      (pushInput (x (pop (popFail (loadInput (fail []))))))+      -- On x failure, reset the input,+      -- and go on with the next 'Instr'uctions.+      (loadInput (push H.unit next))+instance+  Routinable repr =>+  Letable TH.Name (Program repr inp) where+  def n (Program v) = Program $ \next ->+    subroutine (LetName n) (v ret) (call (LetName n) next)+  ref _isRec n = Program $ \case+    -- Returning just after a 'call' is useless:+    -- using 'jump' lets the 'ret' of the 'subroutine'+    -- directly return where it would in two 'ret's.+    Instr Ret{} -> jump (LetName n)+    next -> call (LetName n) next+instance+  ( Cursorable (Cursor inp)+  , Branchable repr+  , Failable repr+  , Inputable repr+  , Joinable repr+  , Stackable repr+  ) => Foldable (Program repr inp) where+  {-+  chainPre op p = go <*> p+    where go = (H..) <$> op <*> go <|> pure H.id+  chainPost p op = p <**> go+    where go = (H..) <$> op <*> go <|> pure H.id+  -}

@@ -0,0 +1,92 @@+{-# LANGUAGE UndecidableInstances #-} -- For ShowLetName+module Symantic.Parser.Machine.View where++import Data.Bool (Bool(..))+import Data.Function (($), (.), id)+import Data.Functor ((<$>))+import Data.Kind (Type)+import Data.Semigroup (Semigroup(..))+import Data.String (String, IsString(..))+import Text.Show (Show(..))+import qualified Data.Tree as Tree+import qualified Data.List as List+import qualified Language.Haskell.TH.Syntax as TH++import Symantic.Parser.Grammar.ObserveSharing (ShowLetName(..))+import Symantic.Parser.Machine.Instructions++-- * Type 'ViewMachine'+newtype ViewMachine (showName::Bool) inp (vs:: [Type]) (es::Peano) a+  =     ViewMachine { unViewMachine ::+  Tree.Forest String -> Tree.Forest String }++viewMachine ::+  ViewMachine sN inp vs es a ->+  ViewMachine sN inp vs es a+viewMachine = id++-- | Helper to view a command.+viewInstrCmd :: String -> Tree.Forest String -> Tree.Tree String+viewInstrCmd n = Tree.Node n+-- | Helper to view an argument.+viewInstrArg :: String -> Tree.Forest String -> Tree.Tree String+viewInstrArg n = Tree.Node ("<"<>n<>">")++instance Show (ViewMachine sN inp vs es a) where+  show = drawTree . Tree.Node "" . ($ []) . unViewMachine+    where+    drawTree :: Tree.Tree String -> String+    drawTree  = List.unlines . draw+    draw :: Tree.Tree String -> [String]+    draw (Tree.Node x ts0) = List.lines x <> drawSubTrees ts0+      where+      drawSubTrees [] = []+      drawSubTrees [t] = shift "" "  " (draw t)+      drawSubTrees (t:ts) = shift "" "| " (draw t) <> drawSubTrees ts+      shift first other = List.zipWith (<>) (first : List.repeat other)+instance IsString (ViewMachine sN inp vs es a) where+  fromString s = ViewMachine $ \is -> Tree.Node (fromString s) [] : is++instance Stackable (ViewMachine sN) where+  push a k = ViewMachine $ \is -> viewInstrCmd ("push "<>showsPrec 10 a "") [] : unViewMachine k is+  pop k = ViewMachine $ \is -> viewInstrCmd "pop" [] : unViewMachine k is+  liftI2 f k = ViewMachine $ \is -> viewInstrCmd ("lift "<>showsPrec 10 f "") [] : unViewMachine k is+  swap k = ViewMachine $ \is -> viewInstrCmd "swap" [] : unViewMachine k is+instance Branchable (ViewMachine sN) where+  caseI l r = ViewMachine $ \is -> viewInstrCmd "case"+    [ viewInstrArg "left" (unViewMachine l [])+    , viewInstrArg "right" (unViewMachine r [])+    ] : is+  choices ps bs d = ViewMachine $ \is ->+    viewInstrCmd ("choices "<>show ps) (+      (viewInstrArg "branch" . ($ []) . unViewMachine <$> bs) <>+      [ viewInstrArg "default" (unViewMachine d []) ]+    ) : is+instance Failable (ViewMachine sN) where+  fail _err = ViewMachine $ \is -> viewInstrCmd "fail" [] : is+  popFail k = ViewMachine $ \is -> viewInstrCmd "popFail" [] : unViewMachine k is+  catchFail t h = ViewMachine $ \is -> viewInstrCmd "catchFail"+    [ viewInstrArg "try" (unViewMachine t [])+    , viewInstrArg "handler" (unViewMachine h [])+    ] : is+instance Inputable (ViewMachine sN) where+  loadInput k = ViewMachine $ \is -> viewInstrCmd "loadInput" [] : unViewMachine k is+  pushInput k = ViewMachine $ \is -> viewInstrCmd "pushInput" [] : unViewMachine k is+instance+  ShowLetName sN TH.Name =>+  Routinable (ViewMachine sN) where+  subroutine (LetName n) sub k = ViewMachine $ \is ->+    Tree.Node (showLetName @sN n<>":") (unViewMachine sub [])+    : unViewMachine k is+  jump (LetName n) = ViewMachine $ \is -> viewInstrCmd ("jump "<>showLetName @sN n) [] : is+  call (LetName n) k = ViewMachine $ \is -> viewInstrCmd ("call "<>showLetName @sN n) [] : unViewMachine k is+  ret = ViewMachine $ \is -> viewInstrCmd "ret" [] : is+instance+  ShowLetName sN TH.Name =>+  Joinable (ViewMachine sN) where+  defJoin (LetName n) j k = ViewMachine $ \is ->+    Tree.Node (showLetName @sN n<>":") (unViewMachine j [])+    : unViewMachine k is+  refJoin (LetName n) = ViewMachine $ \is -> viewInstrCmd ("refJoin "<>showLetName @sN n) [] : is+instance Readable tok (ViewMachine sN) where+  read _es p k = ViewMachine $ \is -> viewInstrCmd ("read "<>showsPrec 10 p "") [] : unViewMachine k is

@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes #-} -- For ShowLetName {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE ExistentialQuantification #-} -- For SharingName -- {-# LANGUAGE MagicHash #-} -- For unsafeCoerce#@@ -18,6 +19,7 @@ import Data.Maybe (Maybe(..), isNothing) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..))+import Data.String (String) -- import GHC.Exts (Int(..)) -- import GHC.Prim (unsafeCoerce#) import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)@@ -25,7 +27,7 @@ import Prelude ((+)) import System.IO (IO) import System.IO.Unsafe (unsafePerformIO)--- import Text.Show (Show(..))+import Text.Show (Show(..)) import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Trans.Reader as MT import qualified Control.Monad.Trans.State as MT@@ -37,7 +39,7 @@ -- import Debug.Trace (trace)  -- * Class 'Letable'--- | This class is not for manual usage like usual symantic operators,+-- | This class is not for end-users like usual symantic operators, -- here 'def' and 'ref' are introduced by 'observeSharing'. class Letable letName repr where   -- | @('def' letName x)@ let-binds @(letName)@ to be equal to @(x)@.@@ -59,6 +61,19 @@ class MakeLetName letName where   makeLetName :: SharingName -> IO letName +-- ** Type 'ShowLetName'+-- | Useful on golden unit tests because 'StableName'+-- change often when changing unrelated source code+-- or even changing basic GHC or executable flags.+class ShowLetName (showName::Bool) letName where+  showLetName :: letName -> String+-- | Like 'Show'.+instance Show letName => ShowLetName 'True letName where+  showLetName = show+-- | Always return @"<hidden>"@,+instance ShowLetName 'False letName where+  showLetName _p = "<hidden>"+ -- * Type 'SharingName' -- | Note that the observable sharing enabled by 'StableName' -- is not perfect as it will not observe all the sharing explicitely done.@@ -100,7 +115,8 @@ observeSharing ::   Eq letName =>   Hashable letName =>-  ObserveSharing letName repr a -> repr a+  ObserveSharing letName repr a ->+  repr a observeSharing (ObserveSharing m) = do   let (a, st) = MT.runReaderT m mempty `MT.runState`         ObserveSharingState@@ -125,7 +141,8 @@   Hashable letName =>   Letable letName repr =>   MakeLetName letName =>-  ObserveSharing letName repr a -> ObserveSharing letName repr a+  ObserveSharing letName repr a ->+  ObserveSharing letName repr a observeSharingNode (ObserveSharing m) = ObserveSharing $ do   let nodeName = makeSharingName m   st <- MT.lift MT.get

@@ -17,7 +17,8 @@  -- * Class 'BiTrans' -- | Convenient type class synonym.--- Note that this is not necessarily a bijective 'trans'lation, a 'trans' being not necessarily injective nor surjective.+-- Note that this is not necessarily a bijective 'trans'lation,+-- a 'trans' being not necessarily injective nor surjective. type BiTrans from to = (Trans from to, Trans to from)  -- ** Class 'Liftable'

@@ -1,6 +1,6 @@ cabal-version: 2.4 name: symantic-parser-version: 0.0.0.20210102+version: 0.1.0.20210201 synopsis: Parser combinators statically optimized and staged via typed meta-programming description:   This is a work-in-progress experimental library to generate parsers,@@ -32,9 +32,11 @@   shell.nix   test/Golden/**/*.dump   test/Golden/**/*.txt+  test/Golden/Splice/**/*.hs extra-tmp-files: build-type: Simple-tested-with: GHC==9.0.0+-- build-type: Custom+tested-with: GHC==9.0.1  source-repository head   type: git@@ -76,26 +78,38 @@     -fhide-source-paths     -freverse-errors +-- custom-setup+--   setup-depends:+--     base      >= 4.14,+--     Cabal     >= 3.0,+--     directory >= 1,+--     filepath  >= 1.3+ library   import: boilerplate   hs-source-dirs: src   exposed-modules:-    Symantic.Univariant.Letable-    Symantic.Univariant.Trans     Symantic.Parser     Symantic.Parser.Grammar     Symantic.Parser.Grammar.Combinators-    Symantic.Parser.Grammar.Dump     Symantic.Parser.Grammar.Fixity     Symantic.Parser.Grammar.ObserveSharing     Symantic.Parser.Grammar.Optimize+    Symantic.Parser.Grammar.View     Symantic.Parser.Grammar.Write     Symantic.Parser.Haskell+    Symantic.Parser.Haskell.Optimize+    Symantic.Parser.Haskell.Term+    Symantic.Parser.Haskell.View     Symantic.Parser.Machine-    Symantic.Parser.Machine.Dump     Symantic.Parser.Machine.Generate     Symantic.Parser.Machine.Input     Symantic.Parser.Machine.Instructions+    Symantic.Parser.Machine.Optimize+    Symantic.Parser.Machine.Program+    Symantic.Parser.Machine.View+    Symantic.Univariant.Letable+    Symantic.Univariant.Trans   build-depends:     base >=4.10 && <5,     array,@@ -115,11 +129,17 @@   main-is: Main.hs   other-modules:     Golden-    Golden.Grammar-    -- Golden.Utils-    -- Golden.Parsers+    --Golden.Splice+    --Golden.Utils+    Parser+    Parser.Brainfuck+    Parser.Nandlang+    Parser.Playground+    --Paths_symantic_parser     -- HUnit     -- QuickCheck+  -- autogen-modules:+  --   Paths_symantic_parser   default-extensions:     ViewPatterns   ghc-options:@@ -142,6 +162,7 @@     text >= 1.2,     -- time >= 1.9,     transformers >= 0.4,+    -- turtle >= 1.5,     -- QuickCheck >= 2.0,     -- tasty-quickcheck,     unix >= 2.7,

@@ -2,8 +2,11 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -Wno-unused-local-binds #-} -- For TH splices+{-# OPTIONS_GHC -Wno-unused-matches #-} -- For TH splices module Golden where +import Data.Bool (Bool(..)) import Control.Monad (Monad(..)) import Data.Char (Char) import Data.Either (Either(..))@@ -24,48 +27,48 @@  import qualified Symantic.Parser as P import qualified Symantic.Parser.Haskell as H-import qualified Golden.Grammar as Grammar---import Golden.Utils+import qualified Parser+--import qualified Golden.Splice  goldensIO :: IO TestTree goldensIO = return $ testGroup "Golden"   [ goldensGrammar-  -- Commented-out for the release-  -- because resetTHNameCounter is not enough:-  -- TH names still change between runs-  -- with and without --accept-  -- , goldensMachine+  , goldensMachine   , goldensParser+  -- TODO: this will need cabal-install-3.4 to compile under GHC9.+  --, Golden.Splice.goldens   ]  goldensGrammar :: TestTree goldensGrammar = testGroup "Grammar"-  [ testGroup "DumpComb" $ tests $ \name repr ->+  [ testGroup "ViewGrammar" $ tests $ \name repr ->     let file = "test/Golden/Grammar/"<>name<>".dump" in     goldenVsStringDiff file diffGolden file $ do       resetTHNameCounter       return $ fromString $ show $-        P.dumpComb $ P.observeSharing repr-  , testGroup "OptimizeComb" $ tests $ \name repr ->+        P.viewGrammar @'False $+        P.observeSharing repr+  , testGroup "OptimizeGrammar" $ tests $ \name repr ->     let file = "test/Golden/Grammar/"<>name<>".opt.dump" in     goldenVsStringDiff file diffGolden file $ do       resetTHNameCounter-      return $ fromString $ show $-        P.dumpComb $ P.optimizeComb $ P.observeSharing repr+      return $ fromString $ P.showGrammar @'False repr   ]   where-  tests :: P.Grammar repr =>-           P.Satisfiable repr Char =>+  tests :: P.Grammar Char repr =>            (forall a. String -> repr a -> TestTree) -> [TestTree]   tests test =     [ test "unit" $ P.unit     , test "unit-unit" $ P.unit P.*> P.unit-    , test "app" $ P.pure (H.Haskell H.id) P.<*> P.unit+    , test "app" $ P.pure H.id P.<*> P.unit+    , test "string" $ P.string "abcd"+    , test "tokens" $ P.tokens "abcd"     , test "many-a" $ P.many (P.char 'a')-    , test "boom" $ Grammar.boom-    , test "brainfuck" $ Grammar.brainfuck+    , test "boom" $ Parser.boom+    , test "brainfuck" $ Parser.brainfuck     , test "many-char-eof" $ P.many (P.char 'r') P.<* P.eof     , test "eof" $ P.eof+    , test "nandlang" $ Parser.nandlang     ]  goldensMachine :: TestTree@@ -75,24 +78,26 @@     goldenVsStringDiff file diffGolden file $ do       resetTHNameCounter       return $ fromString $ show $-        P.dumpInstr $ {-P.machine @() $ -}repr+        P.viewMachine @'False repr   ]   where   tests ::-    P.Executable repr =>-    P.Readable repr Char =>+    P.Machine Char repr =>     (forall vs es ret. String -> repr Text vs es ret -> TestTree) -> [TestTree]   tests test =     [ test "unit" $ P.machine $ P.unit     , test "unit-unit" $ P.machine $ P.unit P.*> P.unit+    , test "string" $ P.machine $ P.string "abcd"     , test "a-or-b" $ P.machine $ P.char 'a' P.<|> P.char 'b'-    , test "app" $ P.machine $ P.pure (H.Haskell H.id) P.<*> P.unit+    , test "app" $ P.machine $ P.pure H.id P.<*> P.unit     , test "many-a" $ P.machine $ P.many (P.char 'a')-    , test "boom" $ P.machine $ Grammar.boom-    , test "brainfuck" $ P.machine $ Grammar.brainfuck+    , test "some-string" $ P.machine $ P.some (P.string "abcd")+    , test "boom" $ P.machine $ Parser.boom+    , test "brainfuck" $ P.machine $ Parser.brainfuck     , test "many-char-eof" $ P.machine $ P.many (P.char 'r') P.<* P.eof     , test "eof" $ P.machine $ P.eof     , test "many-char-fail" $ P.machine $ P.many (P.char 'a') P.<* P.char 'b'+    , test "nandlang" $ P.machine $ Parser.nandlang     ]  goldensParser :: TestTree@@ -110,23 +115,29 @@   tests :: (forall a. Show a => String -> (Text -> Either (P.ParsingError Text) a) -> TestTree) -> [TestTree]   tests test =     [ test "char" $$(P.runParser $ P.char 'a')-    , test "string" $$(P.runParser $ P.string "ab")+    , test "string" $$(P.runParser $ P.string "abc")+    , test "string-fail-horizon" $$(P.runParser $ P.string "abc")     , test "many-char" $$(P.runParser $ P.many (P.char 'a'))-    , test "alt-right" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")-    , test "alt-right-try" $$(P.runParser $ P.try (P.string "aa") P.<|> P.string "ab")+    , test "some-string" $$(P.runParser $ P.some (P.string "abcd"))+    , test "some-string-fail" $$(P.runParser $ P.some (P.string "abcd"))+    , test "some-string-eof-fail" $$(P.runParser $ P.some (P.string "abcd") P.<* P.eof)+    , test "alt-right-notry" $$(P.runParser $ P.traverse P.char "aa" P.<|> P.traverse P.char "ab")+    , test "alt-right-try" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")     , test "alt-left" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")     , test "many-char-eof" $$(P.runParser $ P.many (P.char 'r') P.<* P.eof)     , test "eof" $$(P.runParser $ P.eof)     , test "eof-fail" $$(P.runParser $ P.eof)-    -- , test "alt-char-fail" $$(P.runParser $ P.char 'a' P.<|> P.char 'b')-    -- , test "alt-char-fail" $$(P.runParser $ P.some (P.char 'a') P.<|> P.string "b")+    , test "alt-char-fail" $$(P.runParser $ P.char 'a' P.<|> P.char 'b')     , test "many-char-fail" $$(P.runParser $ P.many (P.char 'a') P.<* P.char 'b')-    -- , test "alt-char-try-fail" $$(P.runParser $ P.try (P.char 'a') P.<|> P.char 'b')+    , test "many-oneOf" $$(P.runParser $ P.many (P.oneOf ['a', 'b', 'c', 'd']) P.<* P.eof)     ]  -- | Resetting 'TH.counter' makes 'makeLetName' deterministic,--- except when profiling is enabled, in this case those tests may fail+-- except when GHC or executable flags change, like profiling+-- or even --accept unfortunately,+-- in those case the 'goldensMachine' tests may fail -- due to a different numbering of the 'def' and 'ref' combinators.+-- Hence 'ShowLetName' is used with 'False'. resetTHNameCounter :: IO () resetTHNameCounter = IORef.writeIORef TH.counter 0 

@@ -1,71 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TemplateHaskell #-}-module Golden.Grammar where--import Data.Char (Char)-import Data.Eq (Eq)-import Data.Int (Int)-import Data.String (String)-import Prelude (undefined)-import Text.Show (Show)-import qualified Prelude-import qualified Language.Haskell.TH as TH--import Symantic.Parser-import qualified Symantic.Parser.Haskell as H--data Expr = Var String | Num Int | Add Expr Expr deriving Show-data Asgn = Asgn String Expr deriving Show--data BrainFuckOp = RightPointer | LeftPointer | Increment | Decrement | Output | Input | Loop [BrainFuckOp] deriving (Show, Eq)--{--cinput = m --try (string "aaa") <|> string "db" --(string "aab" <|> string "aac") --(char 'a' <|> char 'b') *> string "ab"-  where-    --m = match "ab" (lookAhead item) op empty-    --op 'a' = item $> haskell "aaaaa"-    --op 'b' = item $> haskell "bbbbb"-    m = bf <* item-    -- match :: Eq a => [Pure repr a] -> repr a -> (Pure repr a -> repr b) -> repr b -> repr b-    bf = match [char '>'] item op empty-    op (H.ValueCode '>' _) = string ">"--}----defuncTest = haskell Just <$> (haskell (+) <$> (item $> haskell 1) <*> (item $> haskell 8))---- manyTest = many (string "ab" $> (haskell 'c'))----nfb = negLook (char 'a') <|> void (string "ab")----skipManyInspect = skipMany (char 'a')--boom :: Applicable repr => repr ()-boom =-  let foo = (-- newRegister_ unit (\r0 ->-       let goo = (-- newRegister_ unit (\r1 ->-             let hoo = {-get r0 <~> get r1 *>-} goo *> hoo in hoo-            ) *> goo-       in goo) *> pure H.unit-  in foo *> foo--haskell :: a -> TH.CodeQ a -> H.Haskell a-haskell e c = H.Haskell (H.ValueCode (H.Value e) c)--brainfuck :: Satisfiable repr Char => Grammar repr => repr [BrainFuckOp]-brainfuck = whitespace *> bf-  where-    whitespace = skipMany (noneOf "<>+-[],.$")-    lexeme p = p <* whitespace-    -- match :: Eq a => [Pure repr a] -> repr a -> (Pure repr a -> repr b) -> repr b -> repr b-    bf = many (lexeme (match ((\c -> haskell c [||c||]) Prelude.<$> "><+-.,[") (look anyChar) op empty))-    --op :: H.Haskell Char -> repr BrainFuckOp-    op (H.Haskell (H.ValueCode (H.Value c) _)) = case c of-     '>' -> anyChar $> haskell RightPointer [||RightPointer||]-     '<' -> anyChar $> haskell LeftPointer  [||LeftPointer||]-     '+' -> anyChar $> haskell Increment    [||Increment||]-     '-' -> anyChar $> haskell Decrement    [||Decrement||]-     '.' -> anyChar $> haskell Output       [||Output||]-     ',' -> anyChar $> haskell Input        [||Input||]-     '[' -> between (lexeme anyChar) (char ']') (haskell Loop [||Loop||] <$> bf)-     _ -> undefined-    op _ = undefined

@@ -1,3 +1,3 @@ <*>-+ pure Haskell-` pure ()++ pure (\u1 -> u1)+` pure Term

@@ -1,1 +1,1 @@-pure (Haskell ())+pure Term

@@ -1,46 +1,46 @@ <*> + <*> | + <*>-| | + pure const-| | ` pure id+| | + pure (\u1 -> (\u2 -> u1))+| | ` pure (\u1 -> u1) | ` <*> |   + <*>-|   | + def name_5+|   | + def <hidden> |   | | ` <*>-|   | |   + pure const-|   | |   ` pure id-|   | ` def name_7+|   | |   + pure (\u1 -> (\u2 -> u1))+|   | |   ` pure (\u1 -> u1)+|   | ` def <hidden> |   |   ` <*> |   |     + <*>-|   |     | + def name_1+|   |     | + def <hidden> |   |     | | ` <*>-|   |     | |   + pure const-|   |     | |   ` pure id-|   |     | ` def name_3+|   |     | |   + pure (\u1 -> (\u2 -> u1))+|   |     | |   ` pure (\u1 -> u1)+|   |     | ` def <hidden> |   |     |   ` <*> |   |     |     + <*> |   |     |     | + <*>-|   |     |     | | + pure const-|   |     |     | | ` pure id-|   |     |     | ` rec name_7-|   |     |     ` rec name_3-|   |     ` rec name_7-|   ` def name_2-|     ` pure ()+|   |     |     | | + pure (\u1 -> (\u2 -> u1))+|   |     |     | | ` pure (\u1 -> u1)+|   |     |     | ` rec <hidden>+|   |     |     ` rec <hidden>+|   |     ` rec <hidden>+|   ` def <hidden>+|     ` pure Term ` <*>   + <*>-  | + ref name_5-  | ` def name_4+  | + ref <hidden>+  | ` def <hidden>   |   ` <*>   |     + <*>-  |     | + ref name_1-  |     | ` def name_6+  |     | + ref <hidden>+  |     | ` def <hidden>   |     |   ` <*>   |     |     + <*>   |     |     | + <*>-  |     |     | | + pure const-  |     |     | | ` pure id-  |     |     | ` rec name_4-  |     |     ` rec name_6-  |     ` rec name_4-  ` ref name_2+  |     |     | | + pure (\u1 -> (\u2 -> u1))+  |     |     | | ` pure (\u1 -> u1)+  |     |     | ` rec <hidden>+  |     |     ` rec <hidden>+  |     ` rec <hidden>+  ` ref <hidden>

@@ -4,33 +4,33 @@ | | + <*> | | | + <*> | | | | + <*>-| | | | | + pure ((.) ((.) (.)) . ((.) ((.) (.)) . (.) ((.) (const id))))-| | | | | ` def name_2-| | | | |   ` pure (const id)-| | | | ` def name_4+| | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> (\u6 -> (u4 u5) u6))))))+| | | | | ` def <hidden>+| | | | |   ` pure (\u1 -> (\u2 -> u2))+| | | | ` def <hidden> | | | |   ` <*> | | | |     + <*>-| | | |     | + def name_5-| | | |     | | ` pure (const id)-| | | |     | ` def name_7+| | | |     | + def <hidden>+| | | |     | | ` pure (\u1 -> (\u2 -> u2))+| | | |     | ` def <hidden> | | | |     |   ` <*> | | | |     |     + <*>-| | | |     |     | + pure (const id)-| | | |     |     | ` rec name_4-| | | |     |     ` rec name_7-| | | |     ` rec name_4-| | | ` def name_6-| | |   ` pure ()-| | ` ref name_2-| ` def name_1+| | | |     |     | + pure (\u1 -> (\u2 -> u2))+| | | |     |     | ` rec <hidden>+| | | |     |     ` rec <hidden>+| | | |     ` rec <hidden>+| | | ` def <hidden>+| | |   ` pure Term+| | ` ref <hidden>+| ` def <hidden> |   ` <*> |     + <*>-|     | + ref name_5-|     | ` def name_3+|     | + ref <hidden>+|     | ` def <hidden> |     |   ` <*> |     |     + <*>-|     |     | + pure (const id)-|     |     | ` rec name_1-|     |     ` rec name_3-|     ` rec name_1-` ref name_6+|     |     | + pure (\u1 -> (\u2 -> u2))+|     |     | ` rec <hidden>+|     |     ` rec <hidden>+|     ` rec <hidden>+` ref <hidden>

@@ -1,140 +1,101 @@ <*> + <*> | + <*>-| | + pure const-| | ` pure id-| ` <*>-|   + <*>-|   | + <*>-|   | | + pure const-|   | | ` pure id-|   | ` <*>-|   |   + <*>-|   |   | + pure (flip ($))-|   |   | ` def name_6-|   |   |   ` pure ()-|   |   ` def name_8-|   |     ` <|>-|   |       + <*>-|   |       | + <*>-|   |       | | + pure (.)-|   |       | | ` <*>-|   |       | |   + def name_2-|   |       | |   | ` <*>-|   |       | |   |   + pure flip-|   |       | |   |   ` pure const-|   |       | |   ` def name_1-|   |       | |     ` satisfy-|   |       | ` rec name_8-|   |       ` pure id-|   ` ref name_6-` def name_4+| | + pure (\u1 -> (\u2 -> u1))+| | ` pure (\u1 -> u1)+| ` def <hidden>+|   ` <*>+|     + <*>+|     | + <*>+|     | | + pure (\u1 -> (\u2 -> u1))+|     | | ` pure (\u1 -> u1)+|     | ` <*>+|     |   + <*>+|     |   | + pure ((\u1 -> (\u2 -> (\u3 -> (u1 u3) u2))) (\u1 -> (\u2 -> u1 u2)))+|     |   | ` pure Term+|     |   ` def <hidden>+|     |     ` <|>+|     |       + <*>+|     |       | + <*>+|     |       | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))+|     |       | | ` <*>+|     |       | |   + <*>+|     |       | |   | + pure (\u1 -> (\u2 -> (\u3 -> (u1 u3) u2)))+|     |       | |   | ` pure (\u1 -> (\u2 -> u1))+|     |       | |   ` def <hidden>+|     |       | |     ` satisfy+|     |       | ` rec <hidden>+|     |       ` pure (\u1 -> u1)+|     ` pure Term+` def <hidden>   ` <*>-    + def name_5+    + def <hidden>     | ` <|>     |   + <*>     |   | + <*>-    |   | | + pure (.)+    |   | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))     |   | | ` <*>     |   | |   + pure cons     |   | |   ` <*>     |   | |     + <*>-    |   | |     | + pure const+    |   | |     | + pure (\u1 -> (\u2 -> u1))     |   | |     | ` conditional+    |   | |     |   + look+    |   | |     |   | ` ref <hidden>     |   | |     |   + bs     |   | |     |   | + <*>     |   | |     |   | | + <*>-    |   | |     |   | | | + pure const-    |   | |     |   | | | ` pure Haskell-    |   | |     |   | | ` ref name_1+    |   | |     |   | | | + pure (\u1 -> (\u2 -> u1))+    |   | |     |   | | | ` pure Term+    |   | |     |   | | ` ref <hidden>     |   | |     |   | + <*>     |   | |     |   | | + <*>-    |   | |     |   | | | + pure const-    |   | |     |   | | | ` pure Haskell-    |   | |     |   | | ` ref name_1+    |   | |     |   | | | + pure (\u1 -> (\u2 -> u1))+    |   | |     |   | | | ` pure Term+    |   | |     |   | | ` ref <hidden>     |   | |     |   | + <*>     |   | |     |   | | + <*>-    |   | |     |   | | | + pure const-    |   | |     |   | | | ` pure Haskell-    |   | |     |   | | ` ref name_1+    |   | |     |   | | | + pure (\u1 -> (\u2 -> u1))+    |   | |     |   | | | ` pure Term+    |   | |     |   | | ` ref <hidden>     |   | |     |   | + <*>     |   | |     |   | | + <*>-    |   | |     |   | | | + pure const-    |   | |     |   | | | ` pure Haskell-    |   | |     |   | | ` ref name_1+    |   | |     |   | | | + pure (\u1 -> (\u2 -> u1))+    |   | |     |   | | | ` pure Term+    |   | |     |   | | ` ref <hidden>     |   | |     |   | + <*>     |   | |     |   | | + <*>-    |   | |     |   | | | + pure const-    |   | |     |   | | | ` pure Haskell-    |   | |     |   | | ` ref name_1+    |   | |     |   | | | + pure (\u1 -> (\u2 -> u1))+    |   | |     |   | | | ` pure Term+    |   | |     |   | | ` ref <hidden>     |   | |     |   | + <*>     |   | |     |   | | + <*>-    |   | |     |   | | | + pure const-    |   | |     |   | | | ` pure Haskell-    |   | |     |   | | ` ref name_1+    |   | |     |   | | | + pure (\u1 -> (\u2 -> u1))+    |   | |     |   | | | ` pure Term+    |   | |     |   | | ` ref <hidden>     |   | |     |   | ` <*>     |   | |     |   |   + <*>-    |   | |     |   |   | + pure const+    |   | |     |   |   | + pure (\u1 -> (\u2 -> u1))     |   | |     |   |   | ` <*>     |   | |     |   |   |   + <*>     |   | |     |   |   |   | + <*>-    |   | |     |   |   |   | | + pure const-    |   | |     |   |   |   | | ` pure id+    |   | |     |   |   |   | | + pure (\u1 -> (\u2 -> u1))+    |   | |     |   |   |   | | ` pure (\u1 -> u1)     |   | |     |   |   |   | ` <*>     |   | |     |   |   |   |   + <*>-    |   | |     |   |   |   |   | + pure const-    |   | |     |   |   |   |   | ` ref name_1-    |   | |     |   |   |   |   ` <*>-    |   | |     |   |   |   |     + <*>-    |   | |     |   |   |   |     | + <*>-    |   | |     |   |   |   |     | | + pure const-    |   | |     |   |   |   |     | | ` pure id-    |   | |     |   |   |   |     | ` <*>-    |   | |     |   |   |   |     |   + <*>-    |   | |     |   |   |   |     |   | + pure (flip ($))-    |   | |     |   |   |   |     |   | ` ref name_6-    |   | |     |   |   |   |     |   ` def name_7-    |   | |     |   |   |   |     |     ` <|>-    |   | |     |   |   |   |     |       + <*>-    |   | |     |   |   |   |     |       | + <*>-    |   | |     |   |   |   |     |       | | + pure (.)-    |   | |     |   |   |   |     |       | | ` <*>-    |   | |     |   |   |   |     |       | |   + ref name_2-    |   | |     |   |   |   |     |       | |   ` ref name_1-    |   | |     |   |   |   |     |       | ` rec name_7-    |   | |     |   |   |   |     |       ` pure id-    |   | |     |   |   |   |     ` ref name_6+    |   | |     |   |   |   |   | + pure (\u1 -> (\u2 -> u1))+    |   | |     |   |   |   |   | ` ref <hidden>+    |   | |     |   |   |   |   ` ref <hidden>     |   | |     |   |   |   ` <*>-    |   | |     |   |   |     + pure Haskell-    |   | |     |   |   |     ` rec name_4+    |   | |     |   |   |     + pure Term+    |   | |     |   |   |     ` rec <hidden>     |   | |     |   |   ` <*>     |   | |     |   |     + <*>-    |   | |     |   |     | + pure const-    |   | |     |   |     | ` pure Haskell-    |   | |     |   |     ` ref name_1-    |   | |     |   + look-    |   | |     |   | ` ref name_1+    |   | |     |   |     | + pure (\u1 -> (\u2 -> u1))+    |   | |     |   |     | ` pure ']'+    |   | |     |   |     ` ref <hidden>     |   | |     |   ` empty-    |   | |     ` <*>-    |   | |       + <*>-    |   | |       | + <*>-    |   | |       | | + pure const-    |   | |       | | ` pure id-    |   | |       | ` <*>-    |   | |       |   + <*>-    |   | |       |   | + pure (flip ($))-    |   | |       |   | ` ref name_6-    |   | |       |   ` def name_3-    |   | |       |     ` <|>-    |   | |       |       + <*>-    |   | |       |       | + <*>-    |   | |       |       | | + pure (.)-    |   | |       |       | | ` <*>-    |   | |       |       | |   + ref name_2-    |   | |       |       | |   ` ref name_1-    |   | |       |       | ` rec name_3-    |   | |       |       ` pure id-    |   | |       ` ref name_6-    |   | ` rec name_5-    |   ` pure id-    ` pure Haskell+    |   | |     ` ref <hidden>+    |   | ` rec <hidden>+    |   ` pure (\u1 -> u1)+    ` pure Term

@@ -1,87 +1,58 @@ <*> + <*>-| + <*>-| | + <*>-| | | + pure ((.) ((.) (const id)) . ((.) (const id) . flip ($)))-| | | ` def name_4-| | |   ` pure ()-| | ` def name_6-| |   ` <|>-| |     + <*>-| |     | + <*>-| |     | | + <*>-| |     | | | + pure ((.) (.))-| |     | | | ` def name_7-| |     | | |   ` pure (flip const)-| |     | | ` satisfy-| |     | ` rec name_6-| |     ` pure id-| ` ref name_4-` def name_2+| + pure (\u1 -> (\u2 -> u2))+| ` def <hidden>+|   ` <*>+|     + pure (\u1 -> Term)+|     ` def <hidden>+|       ` <|>+|         + <*>+|         | + <*>+|         | | + pure (\u1 -> (\u2 -> (\u3 -> u2 u3)))+|         | | ` satisfy+|         | ` rec <hidden>+|         ` pure (\u1 -> u1)+` def <hidden>   ` <*>-    + pure ((flip ($)) Haskell)-    ` def name_3+    + pure (\u1 -> u1 Term)+    ` def <hidden>       ` <|>         + <*>         | + <*>         | | + <*>-        | | | + <*>-        | | | | + conditional-        | | | | | + bs-        | | | | | | + <*>-        | | | | | | | + pure ((.) ((.) ((.) (.))) . ((.) ((.) ((.) cons)) . ((flip ($)) ((.) (const id) . flip ($)) . ((.) . ((.) . ((.) . (const . const Haskell)))))))-        | | | | | | | ` satisfy-        | | | | | | + <*>-        | | | | | | | + pure ((.) ((.) ((.) (.))) . ((.) ((.) ((.) cons)) . ((flip ($)) ((.) (const id) . flip ($)) . ((.) . ((.) . ((.) . (const . const Haskell)))))))-        | | | | | | | ` satisfy-        | | | | | | + <*>-        | | | | | | | + pure ((.) ((.) ((.) (.))) . ((.) ((.) ((.) cons)) . ((flip ($)) ((.) (const id) . flip ($)) . ((.) . ((.) . ((.) . (const . const Haskell)))))))-        | | | | | | | ` satisfy-        | | | | | | + <*>-        | | | | | | | + pure ((.) ((.) ((.) (.))) . ((.) ((.) ((.) cons)) . ((flip ($)) ((.) (const id) . flip ($)) . ((.) . ((.) . ((.) . (const . const Haskell)))))))-        | | | | | | | ` satisfy-        | | | | | | + <*>-        | | | | | | | + pure ((.) ((.) ((.) (.))) . ((.) ((.) ((.) cons)) . ((flip ($)) ((.) (const id) . flip ($)) . ((.) . ((.) . ((.) . (const . const Haskell)))))))-        | | | | | | | ` satisfy-        | | | | | | + <*>-        | | | | | | | + pure ((.) ((.) ((.) (.))) . ((.) ((.) ((.) cons)) . ((flip ($)) ((.) (const id) . flip ($)) . ((.) . ((.) . ((.) . (const . const Haskell)))))))-        | | | | | | | ` satisfy-        | | | | | | ` <*>-        | | | | | |   + <*>-        | | | | | |   | + <*>-        | | | | | |   | | + <*>-        | | | | | |   | | | + <*>-        | | | | | |   | | | | + <*>-        | | | | | |   | | | | | + pure ((.) ((.) ((.) ((.) ((.) ((.) ((.) ((.) (.)))))))) . ((.) ((.) ((.) ((.) ((.) ((.) ((.) ((.) cons))))))) . ((.) ((.) ((.) ((.) ((.) ((flip ($)) ((.) (const id) . flip ($))))))) . ((.) ((.) ((.) ((.) ((.) (.))))) . ((.) ((.) ((.) ((.) ((.) (.))))) . ((.) ((.) ((.) ((.) ((.) (.))))) . ((.) ((.) ((.) ((.) ((.) const)))) . ((.) ((.) ((.) ((.) ((flip ($)) (const Haskell))))) . ((.) ((.) ((.) ((.) (.)))) . ((.) ((.) ((.) ((.) const))) . ((.) ((.) ((.) ((flip ($)) Haskell))) . ((.) ((.) ((.) (.))) . ((.) ((.) ((.) (const id))) . ((flip ($)) ((.) (const id) . flip ($)) . ((.) . ((.) . ((.) . const)))))))))))))))))-        | | | | | |   | | | | | ` satisfy-        | | | | | |   | | | | ` ref name_4-        | | | | | |   | | | ` def name_1-        | | | | | |   | | |   ` <|>-        | | | | | |   | | |     + <*>-        | | | | | |   | | |     | + <*>-        | | | | | |   | | |     | | + <*>-        | | | | | |   | | |     | | | + pure ((.) (.))-        | | | | | |   | | |     | | | ` ref name_7-        | | | | | |   | | |     | | ` satisfy-        | | | | | |   | | |     | ` rec name_1-        | | | | | |   | | |     ` pure id-        | | | | | |   | | ` ref name_4-        | | | | | |   | ` rec name_2-        | | | | | |   ` satisfy-        | | | | | + look-        | | | | | | ` satisfy-        | | | | | ` empty-        | | | | ` ref name_4-        | | | ` def name_5-        | | |   ` <|>-        | | |     + <*>-        | | |     | + <*>-        | | |     | | + <*>-        | | |     | | | + pure ((.) (.))-        | | |     | | | ` ref name_7-        | | |     | | ` satisfy-        | | |     | ` rec name_5-        | | |     ` pure id-        | | ` ref name_4-        | ` rec name_3-        ` pure id+        | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (u1 u2) (u3 u4)))))+        | | | ` conditional+        | | |   + look+        | | |   | ` satisfy+        | | |   + bs+        | | |   | + <*>+        | | |   | | + pure (\u1 -> (\u2 -> cons Term))+        | | |   | | ` satisfy+        | | |   | + <*>+        | | |   | | + pure (\u1 -> (\u2 -> cons Term))+        | | |   | | ` satisfy+        | | |   | + <*>+        | | |   | | + pure (\u1 -> (\u2 -> cons Term))+        | | |   | | ` satisfy+        | | |   | + <*>+        | | |   | | + pure (\u1 -> (\u2 -> cons Term))+        | | |   | | ` satisfy+        | | |   | + <*>+        | | |   | | + pure (\u1 -> (\u2 -> cons Term))+        | | |   | | ` satisfy+        | | |   | + <*>+        | | |   | | + pure (\u1 -> (\u2 -> cons Term))+        | | |   | | ` satisfy+        | | |   | ` <*>+        | | |   |   + <*>+        | | |   |   | + <*>+        | | |   |   | | + <*>+        | | |   |   | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> cons (Term u3))))))+        | | |   |   | | | ` satisfy+        | | |   |   | | ` ref <hidden>+        | | |   |   | ` rec <hidden>+        | | |   |   ` satisfy+        | | |   ` empty+        | | ` ref <hidden>+        | ` rec <hidden>+        ` pure (\u1 -> u1)

@@ -1,16 +1,16 @@ <*>-+ def name_1++ def <hidden> | ` <|> |   + <*> |   | + <*>-|   | | + pure (.)+|   | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3)))) |   | | ` <*> |   | |   + pure cons |   | |   ` <*> |   | |     + <*>-|   | |     | + pure const-|   | |     | ` pure Haskell+|   | |     | + pure (\u1 -> (\u2 -> u1))+|   | |     | ` pure 'a' |   | |     ` satisfy-|   | ` rec name_1-|   ` pure id-` pure Haskell+|   | ` rec <hidden>+|   ` pure (\u1 -> u1)+` pure Term

@@ -1,10 +1,10 @@ <*>-+ pure ((flip ($)) Haskell)-` def name_1++ pure (\u1 -> u1 Term)+` def <hidden>   ` <|>     + <*>     | + <*>-    | | + pure ((.) . (cons . const Haskell))+    | | + pure (\u1 -> (\u2 -> (\u3 -> 'a' : u2 u3)))     | | ` satisfy-    | ` rec name_1-    ` pure id+    | ` rec <hidden>+    ` pure (\u1 -> u1)

@@ -1,20 +1,20 @@ <*> + <*>-| + pure const+| + pure (\u1 -> (\u2 -> u1)) | ` <*>-|   + def name_1+|   + def <hidden> |   | ` <|> |   |   + <*> |   |   | + <*>-|   |   | | + pure (.)+|   |   | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3)))) |   |   | | ` <*> |   |   | |   + pure cons |   |   | |   ` <*> |   |   | |     + <*>-|   |   | |     | + pure const-|   |   | |     | ` pure Haskell+|   |   | |     | + pure (\u1 -> (\u2 -> u1))+|   |   | |     | ` pure 'r' |   |   | |     ` satisfy-|   |   | ` rec name_1-|   |   ` pure id-|   ` pure Haskell+|   |   | ` rec <hidden>+|   |   ` pure (\u1 -> u1)+|   ` pure Term ` eof

@@ -1,12 +1,12 @@ <*> + <*>-| + pure (const . (flip ($)) Haskell)-| ` def name_1+| + pure (\u1 -> (\u2 -> u1 Term))+| ` def <hidden> |   ` <|> |     + <*> |     | + <*>-|     | | + pure ((.) . (cons . const Haskell))+|     | | + pure (\u1 -> (\u2 -> (\u3 -> 'r' : u2 u3))) |     | | ` satisfy-|     | ` rec name_1-|     ` pure id+|     | ` rec <hidden>+|     ` pure (\u1 -> u1) ` eof

@@ -1,25 +0,0 @@-<*>-+ <*>-| + pure const-| ` <*>-|   + def name_2-|   | ` <|>-|   |   + <*>-|   |   | + <*>-|   |   | | + pure (.)-|   |   | | ` <*>-|   |   | |   + pure cons-|   |   | |   ` <*>-|   |   | |     + <*>-|   |   | |     | + pure const-|   |   | |     | ` pure Haskell-|   |   | |     ` def name_1-|   |   | |       ` satisfy-|   |   | ` rec name_2-|   |   ` pure id-|   ` pure Haskell-` <*>-  + <*>-  | + pure const-  | ` pure Haskell-  ` ref name_1

@@ -1,12 +0,0 @@-<*>-+ <*>-| + pure ((flip ($)) (const Haskell) . ((.) . (const . (flip ($)) Haskell)))-| ` def name_1-|   ` <|>-|     + <*>-|     | + <*>-|     | | + pure ((.) . (cons . const Haskell))-|     | | ` satisfy-|     | ` rec name_1-|     ` pure id-` satisfy

@@ -0,0 +1,993 @@+<*>++ <*>+| + pure (\u1 -> (\u2 -> u1))+| ` <*>+|   + <*>+|   | + <*>+|   | | + pure (\u1 -> (\u2 -> u1))+|   | | ` pure (\u1 -> u1)+|   | ` def <hidden>+|   |   ` <*>+|   |     + <*>+|   |     | + <*>+|   |     | | + pure (\u1 -> (\u2 -> u1))+|   |     | | ` pure (\u1 -> u1)+|   |     | ` <*>+|   |     |   + <*>+|   |     |   | + pure ((\u1 -> (\u2 -> (\u3 -> (u1 u3) u2))) (\u1 -> (\u2 -> u1 u2)))+|   |     |   | ` def <hidden>+|   |     |   |   ` pure Term+|   |     |   ` def <hidden>+|   |     |     ` <|>+|   |     |       + <*>+|   |     |       | + <*>+|   |     |       | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))+|   |     |       | | ` <*>+|   |     |       | |   + <*>+|   |     |       | |   | + pure (\u1 -> (\u2 -> (\u3 -> (u1 u3) u2)))+|   |     |       | |   | ` pure (\u1 -> (\u2 -> u1))+|   |     |       | |   ` <|>+|   |     |       | |     + <*>+|   |     |       | |     | + <*>+|   |     |       | |     | | + <*>+|   |     |       | |     | | | + pure (\u1 -> (\u2 -> u1))+|   |     |       | |     | | | ` pure (\u1 -> u1)+|   |     |       | |     | | ` def <hidden>+|   |     |       | |     | |   ` <*>+|   |     |       | |     | |     + <*>+|   |     |       | |     | |     | + <*>+|   |     |       | |     | |     | | + pure (\u1 -> (\u2 -> u1))+|   |     |       | |     | |     | | ` pure (\u1 -> u1)+|   |     |       | |     | |     | ` def <hidden>+|   |     |       | |     | |     |   ` satisfy+|   |     |       | |     | |     ` ref <hidden>+|   |     |       | |     | ` <*>+|   |     |       | |     |   + <*>+|   |     |       | |     |   | + <*>+|   |     |       | |     |   | | + pure (\u1 -> (\u2 -> u1))+|   |     |       | |     |   | | ` pure (\u1 -> u1)+|   |     |       | |     |   | ` <*>+|   |     |       | |     |   |   + <*>+|   |     |       | |     |   |   | + pure ((\u1 -> (\u2 -> (\u3 -> (u1 u3) u2))) (\u1 -> (\u2 -> u1 u2)))+|   |     |       | |     |   |   | ` pure Term+|   |     |       | |     |   |   ` def <hidden>+|   |     |       | |     |   |     ` <|>+|   |     |       | |     |   |       + <*>+|   |     |       | |     |   |       | + <*>+|   |     |       | |     |   |       | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))+|   |     |       | |     |   |       | | ` <*>+|   |     |       | |     |   |       | |   + <*>+|   |     |       | |     |   |       | |   | + pure (\u1 -> (\u2 -> (\u3 -> (u1 u3) u2)))+|   |     |       | |     |   |       | |   | ` pure (\u1 -> (\u2 -> u1))+|   |     |       | |     |   |       | |   ` ref <hidden>+|   |     |       | |     |   |       | ` rec <hidden>+|   |     |       | |     |   |       ` pure (\u1 -> u1)+|   |     |       | |     |   ` pure Term+|   |     |       | |     ` <*>+|   |     |       | |       + <*>+|   |     |       | |       | + <*>+|   |     |       | |       | | + pure (\u1 -> (\u2 -> u1))+|   |     |       | |       | | ` pure (\u1 -> u1)+|   |     |       | |       | ` <*>+|   |     |       | |       |   + <*>+|   |     |       | |       |   | + <*>+|   |     |       | |       |   | | + pure (\u1 -> (\u2 -> u1))+|   |     |       | |       |   | | ` pure (\u1 -> u1)+|   |     |       | |       |   | ` try+|   |     |       | |       |   |   ` <*>+|   |     |       | |       |   |     + <*>+|   |     |       | |       |   |     | + pure cons+|   |     |       | |       |   |     | ` <*>+|   |     |       | |       |   |     |   + <*>+|   |     |       | |       |   |     |   | + pure (\u1 -> (\u2 -> u1))+|   |     |       | |       |   |     |   | ` pure '/'+|   |     |       | |       |   |     |   ` ref <hidden>+|   |     |       | |       |   |     ` <*>+|   |     |       | |       |   |       + <*>+|   |     |       | |       |   |       | + pure cons+|   |     |       | |       |   |       | ` <*>+|   |     |       | |       |   |       |   + <*>+|   |     |       | |       |   |       |   | + pure (\u1 -> (\u2 -> u1))+|   |     |       | |       |   |       |   | ` pure '/'+|   |     |       | |       |   |       |   ` ref <hidden>+|   |     |       | |       |   |       ` pure Term+|   |     |       | |       |   ` <*>+|   |     |       | |       |     + <*>+|   |     |       | |       |     | + <*>+|   |     |       | |       |     | | + pure (\u1 -> (\u2 -> u1))+|   |     |       | |       |     | | ` pure (\u1 -> u1)+|   |     |       | |       |     | ` <*>+|   |     |       | |       |     |   + <*>+|   |     |       | |       |     |   | + pure ((\u1 -> (\u2 -> (\u3 -> (u1 u3) u2))) (\u1 -> (\u2 -> u1 u2)))+|   |     |       | |       |     |   | ` ref <hidden>+|   |     |       | |       |     |   ` def <hidden>+|   |     |       | |       |     |     ` <|>+|   |     |       | |       |     |       + <*>+|   |     |       | |       |     |       | + <*>+|   |     |       | |       |     |       | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))+|   |     |       | |       |     |       | | ` <*>+|   |     |       | |       |     |       | |   + <*>+|   |     |       | |       |     |       | |   | + pure (\u1 -> (\u2 -> (\u3 -> (u1 u3) u2)))+|   |     |       | |       |     |       | |   | ` pure (\u1 -> (\u2 -> u1))+|   |     |       | |       |     |       | |   ` ref <hidden>+|   |     |       | |       |     |       | ` rec <hidden>+|   |     |       | |       |     |       ` pure (\u1 -> u1)+|   |     |       | |       |     ` ref <hidden>+|   |     |       | |       ` ref <hidden>+|   |     |       | ` rec <hidden>+|   |     |       ` pure (\u1 -> u1)+|   |     ` ref <hidden>+|   ` <*>+|     + <*>+|     | + <*>+|     | | + pure (\u1 -> (\u2 -> u1))+|     | | ` pure (\u1 -> u1)+|     | ` <*>+|     |   + <*>+|     |   | + pure ((\u1 -> (\u2 -> (\u3 -> (u1 u3) u2))) (\u1 -> (\u2 -> u1 u2)))+|     |   | ` ref <hidden>+|     |   ` def <hidden>+|     |     ` <|>+|     |       + <*>+|     |       | + <*>+|     |       | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))+|     |       | | ` <*>+|     |       | |   + <*>+|     |       | |   | + pure (\u1 -> (\u2 -> (\u3 -> (u1 u3) u2)))+|     |       | |   | ` pure (\u1 -> (\u2 -> u1))+|     |       | |   ` <*>+|     |       | |     + <*>+|     |       | |     | + <*>+|     |       | |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     | | ` pure (\u1 -> u1)+|     |       | |     | ` <*>+|     |       | |     |   + <*>+|     |       | |     |   | + <*>+|     |       | |     |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   | | ` pure (\u1 -> u1)+|     |       | |     |   | ` <*>+|     |       | |     |   |   + <*>+|     |       | |     |   |   | + <*>+|     |       | |     |   |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |   | | ` pure (\u1 -> u1)+|     |       | |     |   |   | ` <*>+|     |       | |     |   |   |   + <*>+|     |       | |     |   |   |   | + <*>+|     |       | |     |   |   |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |   |   | | ` pure (\u1 -> u1)+|     |       | |     |   |   |   | ` try+|     |       | |     |   |   |   |   ` <*>+|     |       | |     |   |   |   |     + <*>+|     |       | |     |   |   |   |     | + <*>+|     |       | |     |   |   |   |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |   |   |     | | ` pure (\u1 -> u1)+|     |       | |     |   |   |   |     | ` try+|     |       | |     |   |   |   |     |   ` <*>+|     |       | |     |   |   |   |     |     + <*>+|     |       | |     |   |   |   |     |     | + pure cons+|     |       | |     |   |   |   |     |     | ` <*>+|     |       | |     |   |   |   |     |     |   + <*>+|     |       | |     |   |   |   |     |     |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |   |   |     |     |   | ` pure 'f'+|     |       | |     |   |   |   |     |     |   ` ref <hidden>+|     |       | |     |   |   |   |     |     ` <*>+|     |       | |     |   |   |   |     |       + <*>+|     |       | |     |   |   |   |     |       | + pure cons+|     |       | |     |   |   |   |     |       | ` <*>+|     |       | |     |   |   |   |     |       |   + <*>+|     |       | |     |   |   |   |     |       |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |   |   |     |       |   | ` pure 'u'+|     |       | |     |   |   |   |     |       |   ` ref <hidden>+|     |       | |     |   |   |   |     |       ` <*>+|     |       | |     |   |   |   |     |         + <*>+|     |       | |     |   |   |   |     |         | + pure cons+|     |       | |     |   |   |   |     |         | ` <*>+|     |       | |     |   |   |   |     |         |   + <*>+|     |       | |     |   |   |   |     |         |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |   |   |     |         |   | ` pure 'n'+|     |       | |     |   |   |   |     |         |   ` ref <hidden>+|     |       | |     |   |   |   |     |         ` <*>+|     |       | |     |   |   |   |     |           + <*>+|     |       | |     |   |   |   |     |           | + pure cons+|     |       | |     |   |   |   |     |           | ` <*>+|     |       | |     |   |   |   |     |           |   + <*>+|     |       | |     |   |   |   |     |           |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |   |   |     |           |   | ` pure 'c'+|     |       | |     |   |   |   |     |           |   ` ref <hidden>+|     |       | |     |   |   |   |     |           ` <*>+|     |       | |     |   |   |   |     |             + <*>+|     |       | |     |   |   |   |     |             | + pure cons+|     |       | |     |   |   |   |     |             | ` <*>+|     |       | |     |   |   |   |     |             |   + <*>+|     |       | |     |   |   |   |     |             |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |   |   |     |             |   | ` pure 't'+|     |       | |     |   |   |   |     |             |   ` ref <hidden>+|     |       | |     |   |   |   |     |             ` <*>+|     |       | |     |   |   |   |     |               + <*>+|     |       | |     |   |   |   |     |               | + pure cons+|     |       | |     |   |   |   |     |               | ` <*>+|     |       | |     |   |   |   |     |               |   + <*>+|     |       | |     |   |   |   |     |               |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |   |   |     |               |   | ` pure 'i'+|     |       | |     |   |   |   |     |               |   ` ref <hidden>+|     |       | |     |   |   |   |     |               ` <*>+|     |       | |     |   |   |   |     |                 + <*>+|     |       | |     |   |   |   |     |                 | + pure cons+|     |       | |     |   |   |   |     |                 | ` <*>+|     |       | |     |   |   |   |     |                 |   + <*>+|     |       | |     |   |   |   |     |                 |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |   |   |     |                 |   | ` pure 'o'+|     |       | |     |   |   |   |     |                 |   ` ref <hidden>+|     |       | |     |   |   |   |     |                 ` <*>+|     |       | |     |   |   |   |     |                   + <*>+|     |       | |     |   |   |   |     |                   | + pure cons+|     |       | |     |   |   |   |     |                   | ` <*>+|     |       | |     |   |   |   |     |                   |   + <*>+|     |       | |     |   |   |   |     |                   |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |   |   |     |                   |   | ` pure 'n'+|     |       | |     |   |   |   |     |                   |   ` ref <hidden>+|     |       | |     |   |   |   |     |                   ` def <hidden>+|     |       | |     |   |   |   |     |                     ` pure Term+|     |       | |     |   |   |   |     ` def <hidden>+|     |       | |     |   |   |   |       ` negLook+|     |       | |     |   |   |   |         ` ref <hidden>+|     |       | |     |   |   |   ` ref <hidden>+|     |       | |     |   |   ` def <hidden>+|     |       | |     |   |     ` <*>+|     |       | |     |   |       + <*>+|     |       | |     |   |       | + <*>+|     |       | |     |   |       | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |       | | ` pure (\u1 -> u1)+|     |       | |     |   |       | ` try+|     |       | |     |   |       |   ` <*>+|     |       | |     |   |       |     + <*>+|     |       | |     |   |       |     | + <*>+|     |       | |     |   |       |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |       |     | | ` pure (\u1 -> u1)+|     |       | |     |   |       |     | ` ref <hidden>+|     |       | |     |   |       |     ` <*>+|     |       | |     |   |       |       + <*>+|     |       | |     |   |       |       | + <*>+|     |       | |     |   |       |       | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |       |       | | ` pure (\u1 -> u1)+|     |       | |     |   |       |       | ` <*>+|     |       | |     |   |       |       |   + <*>+|     |       | |     |   |       |       |   | + pure ((\u1 -> (\u2 -> (\u3 -> (u1 u3) u2))) (\u1 -> (\u2 -> u1 u2)))+|     |       | |     |   |       |       |   | ` ref <hidden>+|     |       | |     |   |       |       |   ` def <hidden>+|     |       | |     |   |       |       |     ` <|>+|     |       | |     |   |       |       |       + <*>+|     |       | |     |   |       |       |       | + <*>+|     |       | |     |   |       |       |       | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))+|     |       | |     |   |       |       |       | | ` <*>+|     |       | |     |   |       |       |       | |   + <*>+|     |       | |     |   |       |       |       | |   | + pure (\u1 -> (\u2 -> (\u3 -> (u1 u3) u2)))+|     |       | |     |   |       |       |       | |   | ` pure (\u1 -> (\u2 -> u1))+|     |       | |     |   |       |       |       | |   ` ref <hidden>+|     |       | |     |   |       |       |       | ` rec <hidden>+|     |       | |     |   |       |       |       ` pure (\u1 -> u1)+|     |       | |     |   |       |       ` ref <hidden>+|     |       | |     |   |       ` ref <hidden>+|     |       | |     |   ` <*>+|     |       | |     |     + <*>+|     |       | |     |     | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     | ` <*>+|     |       | |     |     |   + <*>+|     |       | |     |     |   | + <*>+|     |       | |     |     |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |   | | ` pure (\u1 -> u1)+|     |       | |     |     |   | ` def <hidden>+|     |       | |     |     |   |   ` <*>+|     |       | |     |     |   |     + <*>+|     |       | |     |     |   |     | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |   |     | ` <*>+|     |       | |     |     |   |     |   + <*>+|     |       | |     |     |   |     |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |   |     |   | ` pure '('+|     |       | |     |     |   |     |   ` ref <hidden>+|     |       | |     |     |   |     ` ref <hidden>+|     |       | |     |     |   ` <*>+|     |       | |     |     |     + <*>+|     |       | |     |     |     | + <*>+|     |       | |     |     |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     | | ` pure (\u1 -> u1)+|     |       | |     |     |     | ` def <hidden>+|     |       | |     |     |     |   ` <|>+|     |       | |     |     |     |     + <*>+|     |       | |     |     |     |     | + <*>+|     |       | |     |     |     |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     | | ` pure Term+|     |       | |     |     |     |     | ` <*>+|     |       | |     |     |     |     |   + <*>+|     |       | |     |     |     |     |   | + <*>+|     |       | |     |     |     |     |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |   | | ` pure (\u1 -> u1)+|     |       | |     |     |     |     |   | ` def <hidden>+|     |       | |     |     |     |     |   |   ` <*>+|     |       | |     |     |     |     |   |     + <*>+|     |       | |     |     |     |     |   |     | + <*>+|     |       | |     |     |     |     |   |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |   |     | | ` pure (\u1 -> u1)+|     |       | |     |     |     |     |   |     | ` ref <hidden>+|     |       | |     |     |     |     |   |     ` <|>+|     |       | |     |     |     |     |   |       + <*>+|     |       | |     |     |     |     |   |       | + <*>+|     |       | |     |     |     |     |   |       | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |   |       | | ` pure Term+|     |       | |     |     |     |     |   |       | ` def <hidden>+|     |       | |     |     |     |     |   |       |   ` <*>+|     |       | |     |     |     |     |   |       |     + <*>+|     |       | |     |     |     |     |   |       |     | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |   |       |     | ` <*>+|     |       | |     |     |     |     |   |       |     |   + <*>+|     |       | |     |     |     |     |   |       |     |   | + <*>+|     |       | |     |     |     |     |   |       |     |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |   |       |     |   | | ` pure (\u1 -> u1)+|     |       | |     |     |     |     |   |       |     |   | ` <*>+|     |       | |     |     |     |     |   |       |     |   |   + <*>+|     |       | |     |     |     |     |   |       |     |   |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |   |       |     |   |   | ` <*>+|     |       | |     |     |     |     |   |       |     |   |   |   + <*>+|     |       | |     |     |     |     |   |       |     |   |   |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |   |       |     |   |   |   | ` pure '['+|     |       | |     |     |     |     |   |       |     |   |   |   ` ref <hidden>+|     |       | |     |     |     |     |   |       |     |   |   ` ref <hidden>+|     |       | |     |     |     |     |   |       |     |   ` <*>+|     |       | |     |     |     |     |   |       |     |     + <*>+|     |       | |     |     |     |     |   |       |     |     | + <*>+|     |       | |     |     |     |     |   |       |     |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |   |       |     |     | | ` pure (\u1 -> u1)+|     |       | |     |     |     |     |   |       |     |     | ` ref <hidden>+|     |       | |     |     |     |     |   |       |     |     ` <*>+|     |       | |     |     |     |     |   |       |     |       + <*>+|     |       | |     |     |     |     |   |       |     |       | + <*>+|     |       | |     |     |     |     |   |       |     |       | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |   |       |     |       | | ` pure (\u1 -> u1)+|     |       | |     |     |     |     |   |       |     |       | ` <*>+|     |       | |     |     |     |     |   |       |     |       |   + <*>+|     |       | |     |     |     |     |   |       |     |       |   | + pure ((\u1 -> (\u2 -> (\u3 -> (u1 u3) u2))) (\u1 -> (\u2 -> u1 u2)))+|     |       | |     |     |     |     |   |       |     |       |   | ` pure Term+|     |       | |     |     |     |     |   |       |     |       |   ` def <hidden>+|     |       | |     |     |     |     |   |       |     |       |     ` <|>+|     |       | |     |     |     |     |   |       |     |       |       + <*>+|     |       | |     |     |     |     |   |       |     |       |       | + <*>+|     |       | |     |     |     |     |   |       |     |       |       | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))+|     |       | |     |     |     |     |   |       |     |       |       | | ` <*>+|     |       | |     |     |     |     |   |       |     |       |       | |   + <*>+|     |       | |     |     |     |     |   |       |     |       |       | |   | + pure (\u1 -> (\u2 -> (\u3 -> (u1 u3) u2)))+|     |       | |     |     |     |     |   |       |     |       |       | |   | ` pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |   |       |     |       |       | |   ` ref <hidden>+|     |       | |     |     |     |     |   |       |     |       |       | ` rec <hidden>+|     |       | |     |     |     |     |   |       |     |       |       ` pure (\u1 -> u1)+|     |       | |     |     |     |     |   |       |     |       ` pure Term+|     |       | |     |     |     |     |   |       |     ` <*>+|     |       | |     |     |     |     |   |       |       + <*>+|     |       | |     |     |     |     |   |       |       | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |   |       |       | ` <*>+|     |       | |     |     |     |     |   |       |       |   + <*>+|     |       | |     |     |     |     |   |       |       |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |   |       |       |   | ` pure ']'+|     |       | |     |     |     |     |   |       |       |   ` ref <hidden>+|     |       | |     |     |     |     |   |       |       ` ref <hidden>+|     |       | |     |     |     |     |   |       ` ref <hidden>+|     |       | |     |     |     |     |   ` <*>+|     |       | |     |     |     |     |     + <*>+|     |       | |     |     |     |     |     | + <*>+|     |       | |     |     |     |     |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |     | | ` pure (\u1 -> u1)+|     |       | |     |     |     |     |     | ` <*>+|     |       | |     |     |     |     |     |   + <*>+|     |       | |     |     |     |     |     |   | + pure ((\u1 -> (\u2 -> (\u3 -> (u1 u3) u2))) (\u1 -> (\u2 -> u1 u2)))+|     |       | |     |     |     |     |     |   | ` ref <hidden>+|     |       | |     |     |     |     |     |   ` def <hidden>+|     |       | |     |     |     |     |     |     ` <|>+|     |       | |     |     |     |     |     |       + <*>+|     |       | |     |     |     |     |     |       | + <*>+|     |       | |     |     |     |     |     |       | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))+|     |       | |     |     |     |     |     |       | | ` <*>+|     |       | |     |     |     |     |     |       | |   + def <hidden>+|     |       | |     |     |     |     |     |       | |   | ` <*>+|     |       | |     |     |     |     |     |       | |   |   + pure (\u1 -> (\u2 -> (\u3 -> (u1 u3) u2)))+|     |       | |     |     |     |     |     |       | |   |   ` pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |     |       | |   ` <*>+|     |       | |     |     |     |     |     |       | |     + <*>+|     |       | |     |     |     |     |     |       | |     | + <*>+|     |       | |     |     |     |     |     |       | |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |     |       | |     | | ` pure (\u1 -> u1)+|     |       | |     |     |     |     |     |       | |     | ` def <hidden>+|     |       | |     |     |     |     |     |       | |     |   ` <*>+|     |       | |     |     |     |     |     |       | |     |     + <*>+|     |       | |     |     |     |     |     |       | |     |     | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |     |       | |     |     | ` <*>+|     |       | |     |     |     |     |     |       | |     |     |   + <*>+|     |       | |     |     |     |     |     |       | |     |     |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |     |     |     |       | |     |     |   | ` pure ','+|     |       | |     |     |     |     |     |       | |     |     |   ` ref <hidden>+|     |       | |     |     |     |     |     |       | |     |     ` ref <hidden>+|     |       | |     |     |     |     |     |       | |     ` ref <hidden>+|     |       | |     |     |     |     |     |       | ` rec <hidden>+|     |       | |     |     |     |     |     |       ` pure (\u1 -> u1)+|     |       | |     |     |     |     |     ` ref <hidden>+|     |       | |     |     |     |     ` ref <hidden>+|     |       | |     |     |     ` <|>+|     |       | |     |     |       + <*>+|     |       | |     |     |       | + <*>+|     |       | |     |     |       | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |       | | ` pure Term+|     |       | |     |     |       | ` <*>+|     |       | |     |     |       |   + <*>+|     |       | |     |     |       |   | + <*>+|     |       | |     |     |       |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |       |   | | ` pure (\u1 -> u1)+|     |       | |     |     |       |   | ` <*>+|     |       | |     |     |       |   |   + <*>+|     |       | |     |     |       |   |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |       |   |   | ` <*>+|     |       | |     |     |       |   |   |   + <*>+|     |       | |     |     |       |   |   |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |     |       |   |   |   | ` pure ':'+|     |       | |     |     |       |   |   |   ` ref <hidden>+|     |       | |     |     |       |   |   ` ref <hidden>+|     |       | |     |     |       |   ` ref <hidden>+|     |       | |     |     |       ` ref <hidden>+|     |       | |     |     ` def <hidden>+|     |       | |     |       ` <*>+|     |       | |     |         + <*>+|     |       | |     |         | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |         | ` <*>+|     |       | |     |         |   + <*>+|     |       | |     |         |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |     |         |   | ` pure ')'+|     |       | |     |         |   ` ref <hidden>+|     |       | |     |         ` ref <hidden>+|     |       | |     ` def <hidden>+|     |       | |       ` <*>+|     |       | |         + <*>+|     |       | |         | + pure (\u1 -> (\u2 -> u1))+|     |       | |         | ` <*>+|     |       | |         |   + <*>+|     |       | |         |   | + <*>+|     |       | |         |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |   | | ` pure (\u1 -> u1)+|     |       | |         |   | ` <*>+|     |       | |         |   |   + <*>+|     |       | |         |   |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |   |   | ` <*>+|     |       | |         |   |   |   + <*>+|     |       | |         |   |   |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |   |   |   | ` pure '{'+|     |       | |         |   |   |   ` ref <hidden>+|     |       | |         |   |   ` ref <hidden>+|     |       | |         |   ` <*>+|     |       | |         |     + <*>+|     |       | |         |     | + <*>+|     |       | |         |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     | | ` pure (\u1 -> u1)+|     |       | |         |     | ` <*>+|     |       | |         |     |   + <*>+|     |       | |         |     |   | + pure ((\u1 -> (\u2 -> (\u3 -> (u1 u3) u2))) (\u1 -> (\u2 -> u1 u2)))+|     |       | |         |     |   | ` ref <hidden>+|     |       | |         |     |   ` def <hidden>+|     |       | |         |     |     ` <|>+|     |       | |         |     |       + <*>+|     |       | |         |     |       | + <*>+|     |       | |         |     |       | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))+|     |       | |         |     |       | | ` <*>+|     |       | |         |     |       | |   + <*>+|     |       | |         |     |       | |   | + pure (\u1 -> (\u2 -> (\u3 -> (u1 u3) u2)))+|     |       | |         |     |       | |   | ` pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |   ` <|>+|     |       | |         |     |       | |     + <|>+|     |       | |         |     |       | |     | + <|>+|     |       | |         |     |       | |     | | + <*>+|     |       | |         |     |       | |     | | | + <*>+|     |       | |         |     |       | |     | | | | + <*>+|     |       | |         |     |       | |     | | | | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | | ` <*>+|     |       | |         |     |       | |     | | | |   + <*>+|     |       | |         |     |       | |     | | | |   | + <*>+|     |       | |         |     |       | |     | | | |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   | ` <*>+|     |       | |         |     |       | |     | | | |   |   + <*>+|     |       | |         |     |       | |     | | | |   |   | + <*>+|     |       | |         |     |       | |     | | | |   |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |   | ` <*>+|     |       | |         |     |       | |     | | | |   |   |   + <*>+|     |       | |         |     |       | |     | | | |   |   |   | + <*>+|     |       | |         |     |       | |     | | | |   |   |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |   |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |   |   | ` try+|     |       | |         |     |       | |     | | | |   |   |   |   ` <*>+|     |       | |         |     |       | |     | | | |   |   |   |     + <*>+|     |       | |         |     |       | |     | | | |   |   |   |     | + <*>+|     |       | |         |     |       | |     | | | |   |   |   |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |   |   |     | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |   |   |     | ` try+|     |       | |         |     |       | |     | | | |   |   |   |     |   ` <*>+|     |       | |         |     |       | |     | | | |   |   |   |     |     + <*>+|     |       | |         |     |       | |     | | | |   |   |   |     |     | + pure cons+|     |       | |         |     |       | |     | | | |   |   |   |     |     | ` <*>+|     |       | |         |     |       | |     | | | |   |   |   |     |     |   + <*>+|     |       | |         |     |       | |     | | | |   |   |   |     |     |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |   |   |     |     |   | ` pure 'i'+|     |       | |         |     |       | |     | | | |   |   |   |     |     |   ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |   |   |     |     ` <*>+|     |       | |         |     |       | |     | | | |   |   |   |     |       + <*>+|     |       | |         |     |       | |     | | | |   |   |   |     |       | + pure cons+|     |       | |         |     |       | |     | | | |   |   |   |     |       | ` <*>+|     |       | |         |     |       | |     | | | |   |   |   |     |       |   + <*>+|     |       | |         |     |       | |     | | | |   |   |   |     |       |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |   |   |     |       |   | ` pure 'f'+|     |       | |         |     |       | |     | | | |   |   |   |     |       |   ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |   |   |     |       ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |   |   |     ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |   |   ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |   ` def <hidden>+|     |       | |         |     |       | |     | | | |   |     ` <*>+|     |       | |         |     |       | |     | | | |   |       + <*>+|     |       | |         |     |       | |     | | | |   |       | + <*>+|     |       | |         |     |       | |     | | | |   |       | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |       | ` def <hidden>+|     |       | |         |     |       | |     | | | |   |       |   ` <|>+|     |       | |         |     |       | |     | | | |   |       |     + <|>+|     |       | |         |     |       | |     | | | |   |       |     | + <*>+|     |       | |         |     |       | |     | | | |   |       |     | | + <*>+|     |       | |         |     |       | |     | | | |   |       |     | | | + <*>+|     |       | |         |     |       | |     | | | |   |       |     | | | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |     | | | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |       |     | | | ` <|>+|     |       | |         |     |       | |     | | | |   |       |     | | |   + <*>+|     |       | |         |     |       | |     | | | |   |       |     | | |   | + <*>+|     |       | |         |     |       | |     | | | |   |       |     | | |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |     | | |   | | ` pure '0'+|     |       | |         |     |       | |     | | | |   |       |     | | |   | ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |     | | |   ` <*>+|     |       | |         |     |       | |     | | | |   |       |     | | |     + <*>+|     |       | |         |     |       | |     | | | |   |       |     | | |     | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |     | | |     | ` pure '1'+|     |       | |         |     |       | |     | | | |   |       |     | | |     ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |     | | ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |     | ` <*>+|     |       | |         |     |       | |     | | | |   |       |     |   + <*>+|     |       | |         |     |       | |     | | | |   |       |     |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |     |   | ` <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |   + <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |   | + <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |     |   |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |       |     |   |   | ` <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |   |   + <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |   |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |     |   |   |   | ` pure '\''+|     |       | |         |     |       | |     | | | |   |       |     |   |   |   ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |     |   |   ` <|>+|     |       | |         |     |       | |     | | | |   |       |     |   |     + <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |     | + <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |     | | + <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |     | | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |     |   |     | | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |       |     |   |     | | ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |     |   |     | ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |     |   |     ` <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |       + <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |       | + <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |       | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |     |   |       | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |       |     |   |       | ` <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |       |   + <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |       |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |     |   |       |   | ` pure '\\'+|     |       | |         |     |       | |     | | | |   |       |     |   |       |   ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |     |   |       ` <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |         + <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |         | + <*>+|     |       | |         |     |       | |     | | | |   |       |     |   |         | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |     |   |         | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |       |     |   |         | ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |     |   |         ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |     |   ` <*>+|     |       | |         |     |       | |     | | | |   |       |     |     + <*>+|     |       | |         |     |       | |     | | | |   |       |     |     | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |     |     | ` <*>+|     |       | |         |     |       | |     | | | |   |       |     |     |   + <*>+|     |       | |         |     |       | |     | | | |   |       |     |     |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |     |     |   | ` pure '\''+|     |       | |         |     |       | |     | | | |   |       |     |     |   ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |     |     ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |     ` <*>+|     |       | |         |     |       | |     | | | |   |       |       + <*>+|     |       | |         |     |       | |     | | | |   |       |       | + <*>+|     |       | |         |     |       | |     | | | |   |       |       | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |       | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |       |       | ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |       ` <|>+|     |       | |         |     |       | |     | | | |   |       |         + <*>+|     |       | |         |     |       | |     | | | |   |       |         | + <*>+|     |       | |         |     |       | |     | | | |   |       |         | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |         | | ` pure Term+|     |       | |         |     |       | |     | | | |   |       |         | ` <|>+|     |       | |         |     |       | |     | | | |   |       |         |   + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |         |   | | ` <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |   + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |   | + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |         |   | |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |       |         |   | |   | ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |         |   | |   ` <|>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     | + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |         |   | |     | | ` pure Term+|     |       | |         |     |       | |     | | | |   |       |         |   | |     | ` <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |   + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |   | + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |   | ` rec <hidden>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |   ` <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     | + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     | ` <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |   + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |   | + pure ((\u1 -> (\u2 -> (\u3 -> (u1 u3) u2))) (\u1 -> (\u2 -> u1 u2)))+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |   | ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |   ` def <hidden>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |     ` <|>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       | + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       | | ` <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       | |   + ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       | |   ` <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       | |     + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       | |     | + <*>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       | |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       | |     | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       | |     | ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       | |     ` rec <hidden>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       | ` rec <hidden>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     |       ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |       |         |   | |     |     ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |         |   | |     ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |         |   | ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |         |   ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       |         ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |       ` <*>+|     |       | |         |     |       | |     | | | |   |         + <*>+|     |       | |         |     |       | |     | | | |   |         | + <*>+|     |       | |         |     |       | |     | | | |   |         | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |         | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |         | ` <*>+|     |       | |         |     |       | |     | | | |   |         |   + <*>+|     |       | |         |     |       | |     | | | |   |         |   | + pure ((\u1 -> (\u2 -> (\u3 -> (u1 u3) u2))) (\u1 -> (\u2 -> u1 u2)))+|     |       | |         |     |       | |     | | | |   |         |   | ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |         |   ` def <hidden>+|     |       | |         |     |       | |     | | | |   |         |     ` <|>+|     |       | |         |     |       | |     | | | |   |         |       + <*>+|     |       | |         |     |       | |     | | | |   |         |       | + <*>+|     |       | |         |     |       | |     | | | |   |         |       | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))+|     |       | |         |     |       | |     | | | |   |         |       | | ` <*>+|     |       | |         |     |       | |     | | | |   |         |       | |   + <*>+|     |       | |         |     |       | |     | | | |   |         |       | |   | + pure (\u1 -> (\u2 -> (\u3 -> (u1 u3) u2)))+|     |       | |         |     |       | |     | | | |   |         |       | |   | ` pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |         |       | |   ` <*>+|     |       | |         |     |       | |     | | | |   |         |       | |     + <*>+|     |       | |         |     |       | |     | | | |   |         |       | |     | + <*>+|     |       | |         |     |       | |     | | | |   |         |       | |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |         |       | |     | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |         |       | |     | ` <*>+|     |       | |         |     |       | |     | | | |   |         |       | |     |   + <*>+|     |       | |         |     |       | |     | | | |   |         |       | |     |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |         |       | |     |   | ` <*>+|     |       | |         |     |       | |     | | | |   |         |       | |     |   |   + <*>+|     |       | |         |     |       | |     | | | |   |         |       | |     |   |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | | |   |         |       | |     |   |   | ` pure '!'+|     |       | |         |     |       | |     | | | |   |         |       | |     |   |   ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |         |       | |     |   ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |         |       | |     ` ref <hidden>+|     |       | |         |     |       | |     | | | |   |         |       | ` rec <hidden>+|     |       | |         |     |       | |     | | | |   |         |       ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | | |   |         ` ref <hidden>+|     |       | |         |     |       | |     | | | |   ` rec <hidden>+|     |       | |         |     |       | |     | | | ` <|>+|     |       | |         |     |       | |     | | |   + <*>+|     |       | |         |     |       | |     | | |   | + <*>+|     |       | |         |     |       | |     | | |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | |   | | ` pure Term+|     |       | |         |     |       | |     | | |   | ` <*>+|     |       | |         |     |       | |     | | |   |   + <*>+|     |       | |         |     |       | |     | | |   |   | + <*>+|     |       | |         |     |       | |     | | |   |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | |   |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | |   |   | ` <*>+|     |       | |         |     |       | |     | | |   |   |   + <*>+|     |       | |         |     |       | |     | | |   |   |   | + <*>+|     |       | |         |     |       | |     | | |   |   |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | |   |   |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | |   |   |   | ` try+|     |       | |         |     |       | |     | | |   |   |   |   ` <*>+|     |       | |         |     |       | |     | | |   |   |   |     + <*>+|     |       | |         |     |       | |     | | |   |   |   |     | + <*>+|     |       | |         |     |       | |     | | |   |   |   |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | |   |   |   |     | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | | |   |   |   |     | ` try+|     |       | |         |     |       | |     | | |   |   |   |     |   ` <*>+|     |       | |         |     |       | |     | | |   |   |   |     |     + <*>+|     |       | |         |     |       | |     | | |   |   |   |     |     | + pure cons+|     |       | |         |     |       | |     | | |   |   |   |     |     | ` <*>+|     |       | |         |     |       | |     | | |   |   |   |     |     |   + <*>+|     |       | |         |     |       | |     | | |   |   |   |     |     |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | |   |   |   |     |     |   | ` pure 'e'+|     |       | |         |     |       | |     | | |   |   |   |     |     |   ` ref <hidden>+|     |       | |         |     |       | |     | | |   |   |   |     |     ` <*>+|     |       | |         |     |       | |     | | |   |   |   |     |       + <*>+|     |       | |         |     |       | |     | | |   |   |   |     |       | + pure cons+|     |       | |         |     |       | |     | | |   |   |   |     |       | ` <*>+|     |       | |         |     |       | |     | | |   |   |   |     |       |   + <*>+|     |       | |         |     |       | |     | | |   |   |   |     |       |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | |   |   |   |     |       |   | ` pure 'l'+|     |       | |         |     |       | |     | | |   |   |   |     |       |   ` ref <hidden>+|     |       | |         |     |       | |     | | |   |   |   |     |       ` <*>+|     |       | |         |     |       | |     | | |   |   |   |     |         + <*>+|     |       | |         |     |       | |     | | |   |   |   |     |         | + pure cons+|     |       | |         |     |       | |     | | |   |   |   |     |         | ` <*>+|     |       | |         |     |       | |     | | |   |   |   |     |         |   + <*>+|     |       | |         |     |       | |     | | |   |   |   |     |         |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | |   |   |   |     |         |   | ` pure 's'+|     |       | |         |     |       | |     | | |   |   |   |     |         |   ` ref <hidden>+|     |       | |         |     |       | |     | | |   |   |   |     |         ` <*>+|     |       | |         |     |       | |     | | |   |   |   |     |           + <*>+|     |       | |         |     |       | |     | | |   |   |   |     |           | + pure cons+|     |       | |         |     |       | |     | | |   |   |   |     |           | ` <*>+|     |       | |         |     |       | |     | | |   |   |   |     |           |   + <*>+|     |       | |         |     |       | |     | | |   |   |   |     |           |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | | |   |   |   |     |           |   | ` pure 'e'+|     |       | |         |     |       | |     | | |   |   |   |     |           |   ` ref <hidden>+|     |       | |         |     |       | |     | | |   |   |   |     |           ` ref <hidden>+|     |       | |         |     |       | |     | | |   |   |   |     ` ref <hidden>+|     |       | |         |     |       | |     | | |   |   |   ` ref <hidden>+|     |       | |         |     |       | |     | | |   |   ` rec <hidden>+|     |       | |         |     |       | |     | | |   ` ref <hidden>+|     |       | |         |     |       | |     | | ` <*>+|     |       | |         |     |       | |     | |   + <*>+|     |       | |         |     |       | |     | |   | + <*>+|     |       | |         |     |       | |     | |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | |   | ` <*>+|     |       | |         |     |       | |     | |   |   + <*>+|     |       | |         |     |       | |     | |   |   | + <*>+|     |       | |         |     |       | |     | |   |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | |   |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | |   |   | ` <*>+|     |       | |         |     |       | |     | |   |   |   + <*>+|     |       | |         |     |       | |     | |   |   |   | + <*>+|     |       | |         |     |       | |     | |   |   |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | |   |   |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | |   |   |   | ` try+|     |       | |         |     |       | |     | |   |   |   |   ` <*>+|     |       | |         |     |       | |     | |   |   |   |     + <*>+|     |       | |         |     |       | |     | |   |   |   |     | + <*>+|     |       | |         |     |       | |     | |   |   |   |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | |   |   |   |     | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     | |   |   |   |     | ` try+|     |       | |         |     |       | |     | |   |   |   |     |   ` <*>+|     |       | |         |     |       | |     | |   |   |   |     |     + <*>+|     |       | |         |     |       | |     | |   |   |   |     |     | + pure cons+|     |       | |         |     |       | |     | |   |   |   |     |     | ` <*>+|     |       | |         |     |       | |     | |   |   |   |     |     |   + <*>+|     |       | |         |     |       | |     | |   |   |   |     |     |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | |   |   |   |     |     |   | ` pure 'w'+|     |       | |         |     |       | |     | |   |   |   |     |     |   ` ref <hidden>+|     |       | |         |     |       | |     | |   |   |   |     |     ` <*>+|     |       | |         |     |       | |     | |   |   |   |     |       + <*>+|     |       | |         |     |       | |     | |   |   |   |     |       | + pure cons+|     |       | |         |     |       | |     | |   |   |   |     |       | ` <*>+|     |       | |         |     |       | |     | |   |   |   |     |       |   + <*>+|     |       | |         |     |       | |     | |   |   |   |     |       |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | |   |   |   |     |       |   | ` pure 'h'+|     |       | |         |     |       | |     | |   |   |   |     |       |   ` ref <hidden>+|     |       | |         |     |       | |     | |   |   |   |     |       ` <*>+|     |       | |         |     |       | |     | |   |   |   |     |         + <*>+|     |       | |         |     |       | |     | |   |   |   |     |         | + pure cons+|     |       | |         |     |       | |     | |   |   |   |     |         | ` <*>+|     |       | |         |     |       | |     | |   |   |   |     |         |   + <*>+|     |       | |         |     |       | |     | |   |   |   |     |         |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | |   |   |   |     |         |   | ` pure 'i'+|     |       | |         |     |       | |     | |   |   |   |     |         |   ` ref <hidden>+|     |       | |         |     |       | |     | |   |   |   |     |         ` <*>+|     |       | |         |     |       | |     | |   |   |   |     |           + <*>+|     |       | |         |     |       | |     | |   |   |   |     |           | + pure cons+|     |       | |         |     |       | |     | |   |   |   |     |           | ` <*>+|     |       | |         |     |       | |     | |   |   |   |     |           |   + <*>+|     |       | |         |     |       | |     | |   |   |   |     |           |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | |   |   |   |     |           |   | ` pure 'l'+|     |       | |         |     |       | |     | |   |   |   |     |           |   ` ref <hidden>+|     |       | |         |     |       | |     | |   |   |   |     |           ` <*>+|     |       | |         |     |       | |     | |   |   |   |     |             + <*>+|     |       | |         |     |       | |     | |   |   |   |     |             | + pure cons+|     |       | |         |     |       | |     | |   |   |   |     |             | ` <*>+|     |       | |         |     |       | |     | |   |   |   |     |             |   + <*>+|     |       | |         |     |       | |     | |   |   |   |     |             |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     | |   |   |   |     |             |   | ` pure 'e'+|     |       | |         |     |       | |     | |   |   |   |     |             |   ` ref <hidden>+|     |       | |         |     |       | |     | |   |   |   |     |             ` ref <hidden>+|     |       | |         |     |       | |     | |   |   |   |     ` ref <hidden>+|     |       | |         |     |       | |     | |   |   |   ` ref <hidden>+|     |       | |         |     |       | |     | |   |   ` ref <hidden>+|     |       | |         |     |       | |     | |   ` rec <hidden>+|     |       | |         |     |       | |     | ` try+|     |       | |         |     |       | |     |   ` <*>+|     |       | |         |     |       | |     |     + <*>+|     |       | |         |     |       | |     |     | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     | ` <*>+|     |       | |         |     |       | |     |     |   + <*>+|     |       | |         |     |       | |     |     |   | + <*>+|     |       | |         |     |       | |     |     |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     |     |   | ` <*>+|     |       | |         |     |       | |     |     |   |   + <*>+|     |       | |         |     |       | |     |     |   |   | + <*>+|     |       | |         |     |       | |     |     |   |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     |     |   |   | ` <*>+|     |       | |         |     |       | |     |     |   |   |   + <*>+|     |       | |         |     |       | |     |     |   |   |   | + <*>+|     |       | |         |     |       | |     |     |   |   |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   |   |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     |     |   |   |   | ` <|>+|     |       | |         |     |       | |     |     |   |   |   |   + <*>+|     |       | |         |     |       | |     |     |   |   |   |   | + <*>+|     |       | |         |     |       | |     |     |   |   |   |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   |   |   |   | | ` pure Term+|     |       | |         |     |       | |     |     |   |   |   |   | ` <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   + <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   | + <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   |   |   |   |   | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     |     |   |   |   |   |   | ` try+|     |       | |         |     |       | |     |     |   |   |   |   |   |   ` <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     + <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     | + <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   |   |   |   |   |     | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     |     |   |   |   |   |   |     | ` try+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |   ` <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |     + <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |     | + pure cons+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |     | ` <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |     |   + <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |     |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |     |   | ` pure 'v'+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |     |   ` ref <hidden>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |     ` <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |       + <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |       | + pure cons+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |       | ` <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |       |   + <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |       |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |       |   | ` pure 'a'+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |       |   ` ref <hidden>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |       ` <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |         + <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |         | + pure cons+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |         | ` <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |         |   + <*>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |         |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |         |   | ` pure 'r'+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |         |   ` ref <hidden>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     |         ` ref <hidden>+|     |       | |         |     |       | |     |     |   |   |   |   |   |     ` ref <hidden>+|     |       | |         |     |       | |     |     |   |   |   |   |   ` ref <hidden>+|     |       | |         |     |       | |     |     |   |   |   |   ` ref <hidden>+|     |       | |         |     |       | |     |     |   |   |   ` <*>+|     |       | |         |     |       | |     |     |   |   |     + <*>+|     |       | |         |     |       | |     |     |   |   |     | + <*>+|     |       | |         |     |       | |     |     |   |   |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   |   |     | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     |     |   |   |     | ` ref <hidden>+|     |       | |         |     |       | |     |     |   |   |     ` <*>+|     |       | |         |     |       | |     |     |   |   |       + <*>+|     |       | |         |     |       | |     |     |   |   |       | + <*>+|     |       | |         |     |       | |     |     |   |   |       | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   |   |       | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     |     |   |   |       | ` <*>+|     |       | |         |     |       | |     |     |   |   |       |   + <*>+|     |       | |         |     |       | |     |     |   |   |       |   | + pure ((\u1 -> (\u2 -> (\u3 -> (u1 u3) u2))) (\u1 -> (\u2 -> u1 u2)))+|     |       | |         |     |       | |     |     |   |   |       |   | ` ref <hidden>+|     |       | |         |     |       | |     |     |   |   |       |   ` def <hidden>+|     |       | |         |     |       | |     |     |   |   |       |     ` <|>+|     |       | |         |     |       | |     |     |   |   |       |       + <*>+|     |       | |         |     |       | |     |     |   |   |       |       | + <*>+|     |       | |         |     |       | |     |     |   |   |       |       | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))+|     |       | |         |     |       | |     |     |   |   |       |       | | ` <*>+|     |       | |         |     |       | |     |     |   |   |       |       | |   + ref <hidden>+|     |       | |         |     |       | |     |     |   |   |       |       | |   ` <*>+|     |       | |         |     |       | |     |     |   |   |       |       | |     + <*>+|     |       | |         |     |       | |     |     |   |   |       |       | |     | + <*>+|     |       | |         |     |       | |     |     |   |   |       |       | |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   |   |       |       | |     | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     |     |   |   |       |       | |     | ` ref <hidden>+|     |       | |         |     |       | |     |     |   |   |       |       | |     ` ref <hidden>+|     |       | |         |     |       | |     |     |   |   |       |       | ` rec <hidden>+|     |       | |         |     |       | |     |     |   |   |       |       ` pure (\u1 -> u1)+|     |       | |         |     |       | |     |     |   |   |       ` ref <hidden>+|     |       | |         |     |       | |     |     |   |   ` <*>+|     |       | |         |     |       | |     |     |   |     + <*>+|     |       | |         |     |       | |     |     |   |     | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   |     | ` <*>+|     |       | |         |     |       | |     |     |   |     |   + <*>+|     |       | |         |     |       | |     |     |   |     |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |   |     |   | ` pure '='+|     |       | |         |     |       | |     |     |   |     |   ` ref <hidden>+|     |       | |         |     |       | |     |     |   |     ` ref <hidden>+|     |       | |         |     |       | |     |     |   ` <*>+|     |       | |         |     |       | |     |     |     + <*>+|     |       | |         |     |       | |     |     |     | + <*>+|     |       | |         |     |       | |     |     |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |     | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     |     |     | ` ref <hidden>+|     |       | |         |     |       | |     |     |     ` <*>+|     |       | |         |     |       | |     |     |       + <*>+|     |       | |         |     |       | |     |     |       | + <*>+|     |       | |         |     |       | |     |     |       | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |       | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     |     |       | ` <*>+|     |       | |         |     |       | |     |     |       |   + <*>+|     |       | |         |     |       | |     |     |       |   | + pure ((\u1 -> (\u2 -> (\u3 -> (u1 u3) u2))) (\u1 -> (\u2 -> u1 u2)))+|     |       | |         |     |       | |     |     |       |   | ` ref <hidden>+|     |       | |         |     |       | |     |     |       |   ` def <hidden>+|     |       | |         |     |       | |     |     |       |     ` <|>+|     |       | |         |     |       | |     |     |       |       + <*>+|     |       | |         |     |       | |     |     |       |       | + <*>+|     |       | |         |     |       | |     |     |       |       | | + pure (\u1 -> (\u2 -> (\u3 -> u1 (u2 u3))))+|     |       | |         |     |       | |     |     |       |       | | ` <*>+|     |       | |         |     |       | |     |     |       |       | |   + ref <hidden>+|     |       | |         |     |       | |     |     |       |       | |   ` <*>+|     |       | |         |     |       | |     |     |       |       | |     + <*>+|     |       | |         |     |       | |     |     |       |       | |     | + <*>+|     |       | |         |     |       | |     |     |       |       | |     | | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |     |       |       | |     | | ` pure (\u1 -> u1)+|     |       | |         |     |       | |     |     |       |       | |     | ` ref <hidden>+|     |       | |         |     |       | |     |     |       |       | |     ` ref <hidden>+|     |       | |         |     |       | |     |     |       |       | ` rec <hidden>+|     |       | |         |     |       | |     |     |       |       ` pure (\u1 -> u1)+|     |       | |         |     |       | |     |     |       ` ref <hidden>+|     |       | |         |     |       | |     |     ` def <hidden>+|     |       | |         |     |       | |     |       ` <*>+|     |       | |         |     |       | |     |         + <*>+|     |       | |         |     |       | |     |         | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |         | ` <*>+|     |       | |         |     |       | |     |         |   + <*>+|     |       | |         |     |       | |     |         |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |     |         |   | ` pure ';'+|     |       | |         |     |       | |     |         |   ` ref <hidden>+|     |       | |         |     |       | |     |         ` ref <hidden>+|     |       | |         |     |       | |     ` <*>+|     |       | |         |     |       | |       + <*>+|     |       | |         |     |       | |       | + pure (\u1 -> (\u2 -> u1))+|     |       | |         |     |       | |       | ` ref <hidden>+|     |       | |         |     |       | |       ` ref <hidden>+|     |       | |         |     |       | ` rec <hidden>+|     |       | |         |     |       ` pure (\u1 -> u1)+|     |       | |         |     ` ref <hidden>+|     |       | |         ` <*>+|     |       | |           + <*>+|     |       | |           | + pure (\u1 -> (\u2 -> u1))+|     |       | |           | ` <*>+|     |       | |           |   + <*>+|     |       | |           |   | + pure (\u1 -> (\u2 -> u1))+|     |       | |           |   | ` pure '}'+|     |       | |           |   ` ref <hidden>+|     |       | |           ` ref <hidden>+|     |       | ` rec <hidden>+|     |       ` pure (\u1 -> u1)+|     ` ref <hidden>+` eof

@@ -0,0 +1,479 @@+<*>++ <*>+| + <*>+| | + <*>+| | | + <*>+| | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> u4)))))+| | | | ` def <hidden>+| | | |   ` <*>+| | | |     + <*>+| | | |     | + <*>+| | | |     | | + pure (\u1 -> (\u2 -> (\u3 -> u3)))+| | | |     | | ` def <hidden>+| | | |     | |   ` pure Term+| | | |     | ` def <hidden>+| | | |     |   ` <|>+| | | |     |     + <*>+| | | |     |     | + <*>+| | | |     |     | | + pure (\u1 -> (\u2 -> (\u3 -> u2 u3)))+| | | |     |     | | ` <|>+| | | |     |     | |   + <*>+| | | |     |     | |   | + <*>+| | | |     |     | |   | | + pure (\u1 -> (\u2 -> Term))+| | | |     |     | |   | | ` def <hidden>+| | | |     |     | |   | |   ` <*>+| | | |     |     | |   | |     + <*>+| | | |     |     | |   | |     | + pure (\u1 -> (\u2 -> u2))+| | | |     |     | |   | |     | ` satisfy+| | | |     |     | |   | |     ` ref <hidden>+| | | |     |     | |   | ` def <hidden>+| | | |     |     | |   |   ` <|>+| | | |     |     | |   |     + <*>+| | | |     |     | |   |     | + <*>+| | | |     |     | |   |     | | + pure (\u1 -> (\u2 -> (\u3 -> u2 u3)))+| | | |     |     | |   |     | | ` ref <hidden>+| | | |     |     | |   |     | ` rec <hidden>+| | | |     |     | |   |     ` pure (\u1 -> u1)+| | | |     |     | |   ` <*>+| | | |     |     | |     + <*>+| | | |     |     | |     | + <*>+| | | |     |     | |     | | + <*>+| | | |     |     | |     | | | + <*>+| | | |     |     | |     | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> u5)))))+| | | |     |     | |     | | | | ` try+| | | |     |     | |     | | | |   ` <*>+| | | |     |     | |     | | | |     + <*>+| | | |     |     | |     | | | |     | + pure (\u1 -> (\u2 -> '/' : ('/' : Term)))+| | | |     |     | |     | | | |     | ` satisfy+| | | |     |     | |     | | | |     ` satisfy+| | | |     |     | |     | | | ` ref <hidden>+| | | |     |     | |     | | ` def <hidden>+| | | |     |     | |     | |   ` <|>+| | | |     |     | |     | |     + <*>+| | | |     |     | |     | |     | + <*>+| | | |     |     | |     | |     | | + pure (\u1 -> (\u2 -> (\u3 -> u2 u3)))+| | | |     |     | |     | |     | | ` satisfy+| | | |     |     | |     | |     | ` rec <hidden>+| | | |     |     | |     | |     ` pure (\u1 -> u1)+| | | |     |     | |     | ` ref <hidden>+| | | |     |     | |     ` ref <hidden>+| | | |     |     | ` rec <hidden>+| | | |     |     ` pure (\u1 -> u1)+| | | |     ` ref <hidden>+| | | ` ref <hidden>+| | ` def <hidden>+| |   ` <|>+| |     + <*>+| |     | + <*>+| |     | | + <*>+| |     | | | + <*>+| |     | | | | + <*>+| |     | | | | | + <*>+| |     | | | | | | + <*>+| |     | | | | | | | + <*>+| |     | | | | | | | | + <*>+| |     | | | | | | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> (\u6 -> (\u7 -> (\u8 -> (\u9 -> (\u10 -> u9 u10))))))))))+| |     | | | | | | | | | ` try+| |     | | | | | | | | |   ` <*>+| |     | | | | | | | | |     + <*>+| |     | | | | | | | | |     | + pure (\u1 -> (\u2 -> u2))+| |     | | | | | | | | |     | ` try+| |     | | | | | | | | |     |   ` <*>+| |     | | | | | | | | |     |     + <*>+| |     | | | | | | | | |     |     | + <*>+| |     | | | | | | | | |     |     | | + <*>+| |     | | | | | | | | |     |     | | | + <*>+| |     | | | | | | | | |     |     | | | | + <*>+| |     | | | | | | | | |     |     | | | | | + <*>+| |     | | | | | | | | |     |     | | | | | | + <*>+| |     | | | | | | | | |     |     | | | | | | | + <*>+| |     | | | | | | | | |     |     | | | | | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> (\u6 -> (\u7 -> (\u8 -> (\u9 -> 'f' : ('u' : ('n' : ('c' : ('t' : ('i' : ('o' : ('n' : u9))))))))))))))))+| |     | | | | | | | | |     |     | | | | | | | | ` satisfy+| |     | | | | | | | | |     |     | | | | | | | ` satisfy+| |     | | | | | | | | |     |     | | | | | | ` satisfy+| |     | | | | | | | | |     |     | | | | | ` satisfy+| |     | | | | | | | | |     |     | | | | ` satisfy+| |     | | | | | | | | |     |     | | | ` satisfy+| |     | | | | | | | | |     |     | | ` satisfy+| |     | | | | | | | | |     |     | ` satisfy+| |     | | | | | | | | |     |     ` def <hidden>+| |     | | | | | | | | |     |       ` pure Term+| |     | | | | | | | | |     ` def <hidden>+| |     | | | | | | | | |       ` negLook+| |     | | | | | | | | |         ` satisfy+| |     | | | | | | | | ` ref <hidden>+| |     | | | | | | | ` def <hidden>+| |     | | | | | | |   ` <*>+| |     | | | | | | |     + <*>+| |     | | | | | | |     | + pure (\u1 -> (\u2 -> u2))+| |     | | | | | | |     | ` try+| |     | | | | | | |     |   ` <*>+| |     | | | | | | |     |     + <*>+| |     | | | | | | |     |     | + <*>+| |     | | | | | | |     |     | | + <*>+| |     | | | | | | |     |     | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> u4))))+| |     | | | | | | |     |     | | | ` satisfy+| |     | | | | | | |     |     | | ` ref <hidden>+| |     | | | | | | |     |     | ` def <hidden>+| |     | | | | | | |     |     |   ` <|>+| |     | | | | | | |     |     |     + <*>+| |     | | | | | | |     |     |     | + <*>+| |     | | | | | | |     |     |     | | + pure (\u1 -> (\u2 -> (\u3 -> u2 u3)))+| |     | | | | | | |     |     |     | | ` satisfy+| |     | | | | | | |     |     |     | ` rec <hidden>+| |     | | | | | | |     |     |     ` pure (\u1 -> u1)+| |     | | | | | | |     |     ` ref <hidden>+| |     | | | | | | |     ` ref <hidden>+| |     | | | | | | ` def <hidden>+| |     | | | | | |   ` <*>+| |     | | | | | |     + <*>+| |     | | | | | |     | + pure (\u1 -> (\u2 -> '('))+| |     | | | | | |     | ` satisfy+| |     | | | | | |     ` ref <hidden>+| |     | | | | | ` def <hidden>+| |     | | | | |   ` <|>+| |     | | | | |     + <*>+| |     | | | | |     | + <*>+| |     | | | | |     | | + <*>+| |     | | | | |     | | | + <*>+| |     | | | | |     | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> Term))))+| |     | | | | |     | | | | ` def <hidden>+| |     | | | | |     | | | |   ` <*>+| |     | | | | |     | | | |     + <*>+| |     | | | | |     | | | |     | + pure (\u1 -> (\u2 -> u2))+| |     | | | | |     | | | |     | ` ref <hidden>+| |     | | | | |     | | | |     ` <|>+| |     | | | | |     | | | |       + <*>+| |     | | | | |     | | | |       | + pure (\u1 -> Term)+| |     | | | | |     | | | |       | ` def <hidden>+| |     | | | | |     | | | |       |   ` <*>+| |     | | | | |     | | | |       |     + <*>+| |     | | | | |     | | | |       |     | + <*>+| |     | | | | |     | | | |       |     | | + <*>+| |     | | | | |     | | | |       |     | | | + <*>+| |     | | | | |     | | | |       |     | | | | + <*>+| |     | | | | |     | | | |       |     | | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> (\u6 -> Term))))))+| |     | | | | |     | | | |       |     | | | | | ` satisfy+| |     | | | | |     | | | |       |     | | | | ` ref <hidden>+| |     | | | | |     | | | |       |     | | | ` def <hidden>+| |     | | | | |     | | | |       |     | | |   ` satisfy+| |     | | | | |     | | | |       |     | | ` def <hidden>+| |     | | | | |     | | | |       |     | |   ` <|>+| |     | | | | |     | | | |       |     | |     + <*>+| |     | | | | |     | | | |       |     | |     | + <*>+| |     | | | | |     | | | |       |     | |     | | + pure (\u1 -> (\u2 -> (\u3 -> u2 u3)))+| |     | | | | |     | | | |       |     | |     | | ` ref <hidden>+| |     | | | | |     | | | |       |     | |     | ` rec <hidden>+| |     | | | | |     | | | |       |     | |     ` pure (\u1 -> u1)+| |     | | | | |     | | | |       |     | ` satisfy+| |     | | | | |     | | | |       |     ` ref <hidden>+| |     | | | | |     | | | |       ` ref <hidden>+| |     | | | | |     | | | ` ref <hidden>+| |     | | | | |     | | ` def <hidden>+| |     | | | | |     | |   ` <|>+| |     | | | | |     | |     + <*>+| |     | | | | |     | |     | + <*>+| |     | | | | |     | |     | | + <*>+| |     | | | | |     | |     | | | + <*>+| |     | | | | |     | |     | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> (u1 u3) (u4 u5))))))+| |     | | | | |     | |     | | | | ` def <hidden>+| |     | | | | |     | |     | | | |   ` pure (\u1 -> (\u2 -> u2))+| |     | | | | |     | |     | | | ` def <hidden>+| |     | | | | |     | |     | | |   ` <*>+| |     | | | | |     | |     | | |     + <*>+| |     | | | | |     | |     | | |     | + pure (\u1 -> (\u2 -> ','))+| |     | | | | |     | |     | | |     | ` satisfy+| |     | | | | |     | |     | | |     ` ref <hidden>+| |     | | | | |     | |     | | ` ref <hidden>+| |     | | | | |     | |     | ` rec <hidden>+| |     | | | | |     | |     ` pure (\u1 -> u1)+| |     | | | | |     | ` ref <hidden>+| |     | | | | |     ` ref <hidden>+| |     | | | | ` <|>+| |     | | | |   + <*>+| |     | | | |   | + <*>+| |     | | | |   | | + <*>+| |     | | | |   | | | + pure (\u1 -> (\u2 -> (\u3 -> Term)))+| |     | | | |   | | | ` satisfy+| |     | | | |   | | ` ref <hidden>+| |     | | | |   | ` ref <hidden>+| |     | | | |   ` ref <hidden>+| |     | | | ` def <hidden>+| |     | | |   ` <*>+| |     | | |     + <*>+| |     | | |     | + pure (\u1 -> (\u2 -> ')'))+| |     | | |     | ` satisfy+| |     | | |     ` ref <hidden>+| |     | | ` def <hidden>+| |     | |   ` <*>+| |     | |     + <*>+| |     | |     | + <*>+| |     | |     | | + <*>+| |     | |     | | | + <*>+| |     | |     | | | | + <*>+| |     | |     | | | | | + <*>+| |     | |     | | | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> (\u6 -> (\u7 -> u5)))))))+| |     | |     | | | | | | ` satisfy+| |     | |     | | | | | ` ref <hidden>+| |     | |     | | | | ` ref <hidden>+| |     | |     | | | ` def <hidden>+| |     | |     | | |   ` <|>+| |     | |     | | |     + <*>+| |     | |     | | |     | + <*>+| |     | |     | | |     | | + pure (\u1 -> (\u2 -> (\u3 -> u2 u3)))+| |     | |     | | |     | | ` <|>+| |     | |     | | |     | |   + <*>+| |     | |     | | |     | |   | + <*>+| |     | |     | | |     | |   | | + <*>+| |     | |     | | |     | |   | | | + <*>+| |     | |     | | |     | |   | | | | + <*>+| |     | |     | | |     | |   | | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> u5)))))+| |     | |     | | |     | |   | | | | | ` try+| |     | |     | | |     | |   | | | | |   ` <*>+| |     | |     | | |     | |   | | | | |     + <*>+| |     | |     | | |     | |   | | | | |     | + pure (\u1 -> (\u2 -> u2))+| |     | |     | | |     | |   | | | | |     | ` try+| |     | |     | | |     | |   | | | | |     |   ` <*>+| |     | |     | | |     | |   | | | | |     |     + <*>+| |     | |     | | |     | |   | | | | |     |     | + <*>+| |     | |     | | |     | |   | | | | |     |     | | + pure (\u1 -> (\u2 -> (\u3 -> 'i' : ('f' : u3))))+| |     | |     | | |     | |   | | | | |     |     | | ` satisfy+| |     | |     | | |     | |   | | | | |     |     | ` satisfy+| |     | |     | | |     | |   | | | | |     |     ` ref <hidden>+| |     | |     | | |     | |   | | | | |     ` ref <hidden>+| |     | |     | | |     | |   | | | | ` ref <hidden>+| |     | |     | | |     | |   | | | ` def <hidden>+| |     | |     | | |     | |   | | |   ` <*>+| |     | |     | | |     | |   | | |     + <*>+| |     | |     | | |     | |   | | |     | + <*>+| |     | |     | | |     | |   | | |     | | + <*>+| |     | |     | | |     | |   | | |     | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> u4))))+| |     | |     | | |     | |   | | |     | | | ` def <hidden>+| |     | |     | | |     | |   | | |     | | |   ` <|>+| |     | |     | | |     | |   | | |     | | |     + <*>+| |     | |     | | |     | |   | | |     | | |     | + <*>+| |     | |     | | |     | |   | | |     | | |     | | + pure (\u1 -> (\u2 -> u2))+| |     | |     | | |     | |   | | |     | | |     | | ` <|>+| |     | |     | | |     | |   | | |     | | |     | |   + <*>+| |     | |     | | |     | |   | | |     | | |     | |   | + pure (\u1 -> '0')+| |     | |     | | |     | |   | | |     | | |     | |   | ` satisfy+| |     | |     | | |     | |   | | |     | | |     | |   ` <*>+| |     | |     | | |     | |   | | |     | | |     | |     + pure (\u1 -> '1')+| |     | |     | | |     | |   | | |     | | |     | |     ` satisfy+| |     | |     | | |     | |   | | |     | | |     | ` ref <hidden>+| |     | |     | | |     | |   | | |     | | |     ` <|>+| |     | |     | | |     | |   | | |     | | |       + <*>+| |     | |     | | |     | |   | | |     | | |       | + <*>+| |     | |     | | |     | |   | | |     | | |       | | + <*>+| |     | |     | | |     | |   | | |     | | |       | | | + <*>+| |     | |     | | |     | |   | | |     | | |       | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> u2))))+| |     | |     | | |     | |   | | |     | | |       | | | | ` satisfy+| |     | |     | | |     | |   | | |     | | |       | | | ` <|>+| |     | |     | | |     | |   | | |     | | |       | | |   + <*>+| |     | |     | | |     | |   | | |     | | |       | | |   | + <*>+| |     | |     | | |     | |   | | |     | | |       | | |   | | + pure (\u1 -> (\u2 -> u2))+| |     | |     | | |     | |   | | |     | | |       | | |   | | ` satisfy+| |     | |     | | |     | |   | | |     | | |       | | |   | ` ref <hidden>+| |     | |     | | |     | |   | | |     | | |       | | |   ` <*>+| |     | |     | | |     | |   | | |     | | |       | | |     + <*>+| |     | |     | | |     | |   | | |     | | |       | | |     | + <*>+| |     | |     | | |     | |   | | |     | | |       | | |     | | + pure (\u1 -> (\u2 -> (\u3 -> u3)))+| |     | |     | | |     | |   | | |     | | |       | | |     | | ` satisfy+| |     | |     | | |     | |   | | |     | | |       | | |     | ` satisfy+| |     | |     | | |     | |   | | |     | | |       | | |     ` ref <hidden>+| |     | |     | | |     | |   | | |     | | |       | | ` satisfy+| |     | |     | | |     | |   | | |     | | |       | ` ref <hidden>+| |     | |     | | |     | |   | | |     | | |       ` <*>+| |     | |     | | |     | |   | | |     | | |         + <*>+| |     | |     | | |     | |   | | |     | | |         | + pure (\u1 -> (\u2 -> u2))+| |     | |     | | |     | |   | | |     | | |         | ` ref <hidden>+| |     | |     | | |     | |   | | |     | | |         ` <|>+| |     | |     | | |     | |   | | |     | | |           + <*>+| |     | |     | | |     | |   | | |     | | |           | + pure (\u1 -> Term)+| |     | |     | | |     | |   | | |     | | |           | ` <|>+| |     | |     | | |     | |   | | |     | | |           |   + <*>+| |     | |     | | |     | |   | | |     | | |           |   | + <*>+| |     | |     | | |     | |   | | |     | | |           |   | | + <*>+| |     | |     | | |     | |   | | |     | | |           |   | | | + pure (\u1 -> (\u2 -> (\u3 -> u2)))+| |     | |     | | |     | |   | | |     | | |           |   | | | ` ref <hidden>+| |     | |     | | |     | |   | | |     | | |           |   | | ` <|>+| |     | |     | | |     | |   | | |     | | |           |   | |   + <*>+| |     | |     | | |     | |   | | |     | | |           |   | |   | + <*>+| |     | |     | | |     | |   | | |     | | |           |   | |   | | + <*>+| |     | |     | | |     | |   | | |     | | |           |   | |   | | | + <*>+| |     | |     | | |     | |   | | |     | | |           |   | |   | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> Term))))+| |     | |     | | |     | |   | | |     | | |           |   | |   | | | | ` rec <hidden>+| |     | |     | | |     | |   | | |     | | |           |   | |   | | | ` ref <hidden>+| |     | |     | | |     | |   | | |     | | |           |   | |   | | ` def <hidden>+| |     | |     | | |     | |   | | |     | | |           |   | |   | |   ` <|>+| |     | |     | | |     | |   | | |     | | |           |   | |   | |     + <*>+| |     | |     | | |     | |   | | |     | | |           |   | |   | |     | + <*>+| |     | |     | | |     | |   | | |     | | |           |   | |   | |     | | + <*>+| |     | |     | | |     | |   | | |     | | |           |   | |   | |     | | | + <*>+| |     | |     | | |     | |   | | |     | | |           |   | |   | |     | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> (u1 u3) (u4 u5))))))+| |     | |     | | |     | |   | | |     | | |           |   | |   | |     | | | | ` ref <hidden>+| |     | |     | | |     | |   | | |     | | |           |   | |   | |     | | | ` ref <hidden>+| |     | |     | | |     | |   | | |     | | |           |   | |   | |     | | ` rec <hidden>+| |     | |     | | |     | |   | | |     | | |           |   | |   | |     | ` rec <hidden>+| |     | |     | | |     | |   | | |     | | |           |   | |   | |     ` pure (\u1 -> u1)+| |     | |     | | |     | |   | | |     | | |           |   | |   | ` ref <hidden>+| |     | |     | | |     | |   | | |     | | |           |   | |   ` ref <hidden>+| |     | |     | | |     | |   | | |     | | |           |   | ` ref <hidden>+| |     | |     | | |     | |   | | |     | | |           |   ` ref <hidden>+| |     | |     | | |     | |   | | |     | | |           ` ref <hidden>+| |     | |     | | |     | |   | | |     | | ` ref <hidden>+| |     | |     | | |     | |   | | |     | ` def <hidden>+| |     | |     | | |     | |   | | |     |   ` <|>+| |     | |     | | |     | |   | | |     |     + <*>+| |     | |     | | |     | |   | | |     |     | + <*>+| |     | |     | | |     | |   | | |     |     | | + <*>+| |     | |     | | |     | |   | | |     |     | | | + <*>+| |     | |     | | |     | |   | | |     |     | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> u4 u5)))))+| |     | |     | | |     | |   | | |     |     | | | | ` satisfy+| |     | |     | | |     | |   | | |     |     | | | ` ref <hidden>+| |     | |     | | |     | |   | | |     |     | | ` ref <hidden>+| |     | |     | | |     | |   | | |     |     | ` rec <hidden>+| |     | |     | | |     | |   | | |     |     ` pure (\u1 -> u1)+| |     | |     | | |     | |   | | |     ` ref <hidden>+| |     | |     | | |     | |   | | ` rec <hidden>+| |     | |     | | |     | |   | ` <|>+| |     | |     | | |     | |   |   + <*>+| |     | |     | | |     | |   |   | + <*>+| |     | |     | | |     | |   |   | | + <*>+| |     | |     | | |     | |   |   | | | + pure (\u1 -> (\u2 -> (\u3 -> Term)))+| |     | |     | | |     | |   |   | | | ` try+| |     | |     | | |     | |   |   | | |   ` <*>+| |     | |     | | |     | |   |   | | |     + <*>+| |     | |     | | |     | |   |   | | |     | + pure (\u1 -> (\u2 -> u2))+| |     | |     | | |     | |   |   | | |     | ` try+| |     | |     | | |     | |   |   | | |     |   ` <*>+| |     | |     | | |     | |   |   | | |     |     + <*>+| |     | |     | | |     | |   |   | | |     |     | + <*>+| |     | |     | | |     | |   |   | | |     |     | | + <*>+| |     | |     | | |     | |   |   | | |     |     | | | + <*>+| |     | |     | | |     | |   |   | | |     |     | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> 'e' : ('l' : ('s' : ('e' : u5))))))))+| |     | |     | | |     | |   |   | | |     |     | | | | ` satisfy+| |     | |     | | |     | |   |   | | |     |     | | | ` satisfy+| |     | |     | | |     | |   |   | | |     |     | | ` satisfy+| |     | |     | | |     | |   |   | | |     |     | ` satisfy+| |     | |     | | |     | |   |   | | |     |     ` ref <hidden>+| |     | |     | | |     | |   |   | | |     ` ref <hidden>+| |     | |     | | |     | |   |   | | ` ref <hidden>+| |     | |     | | |     | |   |   | ` rec <hidden>+| |     | |     | | |     | |   |   ` ref <hidden>+| |     | |     | | |     | |   ` <|>+| |     | |     | | |     | |     + <*>+| |     | |     | | |     | |     | + <*>+| |     | |     | | |     | |     | | + <*>+| |     | |     | | |     | |     | | | + <*>+| |     | |     | | |     | |     | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> u4))))+| |     | |     | | |     | |     | | | | ` try+| |     | |     | | |     | |     | | | |   ` <*>+| |     | |     | | |     | |     | | | |     + <*>+| |     | |     | | |     | |     | | | |     | + pure (\u1 -> (\u2 -> u2))+| |     | |     | | |     | |     | | | |     | ` try+| |     | |     | | |     | |     | | | |     |   ` <*>+| |     | |     | | |     | |     | | | |     |     + <*>+| |     | |     | | |     | |     | | | |     |     | + <*>+| |     | |     | | |     | |     | | | |     |     | | + <*>+| |     | |     | | |     | |     | | | |     |     | | | + <*>+| |     | |     | | |     | |     | | | |     |     | | | | + <*>+| |     | |     | | |     | |     | | | |     |     | | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> (\u6 -> 'w' : ('h' : ('i' : ('l' : ('e' : u6))))))))))+| |     | |     | | |     | |     | | | |     |     | | | | | ` satisfy+| |     | |     | | |     | |     | | | |     |     | | | | ` satisfy+| |     | |     | | |     | |     | | | |     |     | | | ` satisfy+| |     | |     | | |     | |     | | | |     |     | | ` satisfy+| |     | |     | | |     | |     | | | |     |     | ` satisfy+| |     | |     | | |     | |     | | | |     |     ` ref <hidden>+| |     | |     | | |     | |     | | | |     ` ref <hidden>+| |     | |     | | |     | |     | | | ` ref <hidden>+| |     | |     | | |     | |     | | ` ref <hidden>+| |     | |     | | |     | |     | ` rec <hidden>+| |     | |     | | |     | |     ` <|>+| |     | |     | | |     | |       + try+| |     | |     | | |     | |       | ` <*>+| |     | |     | | |     | |       |   + <*>+| |     | |     | | |     | |       |   | + <*>+| |     | |     | | |     | |       |   | | + <*>+| |     | |     | | |     | |       |   | | | + <*>+| |     | |     | | |     | |       |   | | | | + <*>+| |     | |     | | |     | |       |   | | | | | + <*>+| |     | |     | | |     | |       |   | | | | | | + <*>+| |     | |     | | |     | |       |   | | | | | | | + <*>+| |     | |     | | |     | |       |   | | | | | | | | + <*>+| |     | |     | | |     | |       |   | | | | | | | | | + <*>+| |     | |     | | |     | |       |   | | | | | | | | | | + <*>+| |     | |     | | |     | |       |   | | | | | | | | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> (\u6 -> (\u7 -> (\u8 -> (\u9 -> (\u10 -> (\u11 -> (\u12 -> u11))))))))))))+| |     | |     | | |     | |       |   | | | | | | | | | | | ` <|>+| |     | |     | | |     | |       |   | | | | | | | | | | |   + <*>+| |     | |     | | |     | |       |   | | | | | | | | | | |   | + <*>+| |     | |     | | |     | |       |   | | | | | | | | | | |   | | + pure (\u1 -> (\u2 -> Term))+| |     | |     | | |     | |       |   | | | | | | | | | | |   | | ` try+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |   ` <*>+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |     + <*>+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |     | + pure (\u1 -> (\u2 -> u2))+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |     | ` try+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |     |   ` <*>+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |     |     + <*>+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |     |     | + <*>+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |     |     | | + <*>+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |     |     | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> 'v' : ('a' : ('r' : u4))))))+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |     |     | | | ` satisfy+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |     |     | | ` satisfy+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |     |     | ` satisfy+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |     |     ` ref <hidden>+| |     | |     | | |     | |       |   | | | | | | | | | | |   | |     ` ref <hidden>+| |     | |     | | |     | |       |   | | | | | | | | | | |   | ` ref <hidden>+| |     | |     | | |     | |       |   | | | | | | | | | | |   ` ref <hidden>+| |     | |     | | |     | |       |   | | | | | | | | | | ` ref <hidden>+| |     | |     | | |     | |       |   | | | | | | | | | ` ref <hidden>+| |     | |     | | |     | |       |   | | | | | | | | ` def <hidden>+| |     | |     | | |     | |       |   | | | | | | | |   ` <|>+| |     | |     | | |     | |       |   | | | | | | | |     + <*>+| |     | |     | | |     | |       |   | | | | | | | |     | + <*>+| |     | |     | | |     | |       |   | | | | | | | |     | | + <*>+| |     | |     | | |     | |       |   | | | | | | | |     | | | + <*>+| |     | |     | | |     | |       |   | | | | | | | |     | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> (u1 u3) (u4 u5))))))+| |     | |     | | |     | |       |   | | | | | | | |     | | | | ` ref <hidden>+| |     | |     | | |     | |       |   | | | | | | | |     | | | ` ref <hidden>+| |     | |     | | |     | |       |   | | | | | | | |     | | ` ref <hidden>+| |     | |     | | |     | |       |   | | | | | | | |     | ` rec <hidden>+| |     | |     | | |     | |       |   | | | | | | | |     ` pure (\u1 -> u1)+| |     | |     | | |     | |       |   | | | | | | | ` ref <hidden>+| |     | |     | | |     | |       |   | | | | | | ` satisfy+| |     | |     | | |     | |       |   | | | | | ` ref <hidden>+| |     | |     | | |     | |       |   | | | | ` ref <hidden>+| |     | |     | | |     | |       |   | | | ` ref <hidden>+| |     | |     | | |     | |       |   | | ` def <hidden>+| |     | |     | | |     | |       |   | |   ` <|>+| |     | |     | | |     | |       |   | |     + <*>+| |     | |     | | |     | |       |   | |     | + <*>+| |     | |     | | |     | |       |   | |     | | + <*>+| |     | |     | | |     | |       |   | |     | | | + <*>+| |     | |     | | |     | |       |   | |     | | | | + pure (\u1 -> (\u2 -> (\u3 -> (\u4 -> (\u5 -> (u1 u3) (u4 u5))))))+| |     | |     | | |     | |       |   | |     | | | | ` ref <hidden>+| |     | |     | | |     | |       |   | |     | | | ` ref <hidden>+| |     | |     | | |     | |       |   | |     | | ` ref <hidden>+| |     | |     | | |     | |       |   | |     | ` rec <hidden>+| |     | |     | | |     | |       |   | |     ` pure (\u1 -> u1)+| |     | |     | | |     | |       |   | ` ref <hidden>+| |     | |     | | |     | |       |   ` def <hidden>+| |     | |     | | |     | |       |     ` <*>+| |     | |     | | |     | |       |       + <*>+| |     | |     | | |     | |       |       | + pure (\u1 -> (\u2 -> ';'))+| |     | |     | | |     | |       |       | ` satisfy+| |     | |     | | |     | |       |       ` ref <hidden>+| |     | |     | | |     | |       ` <*>+| |     | |     | | |     | |         + <*>+| |     | |     | | |     | |         | + pure (\u1 -> (\u2 -> u1))+| |     | |     | | |     | |         | ` ref <hidden>+| |     | |     | | |     | |         ` ref <hidden>+| |     | |     | | |     | ` rec <hidden>+| |     | |     | | |     ` pure (\u1 -> u1)+| |     | |     | | ` ref <hidden>+| |     | |     | ` satisfy+| |     | |     ` ref <hidden>+| |     | ` rec <hidden>+| |     ` pure (\u1 -> u1)+| ` ref <hidden>+` eof