parsley-core 2.0.0.0 → 2.1.0.0

raw patch · 37 files changed

+2170/−221 lines, 37 filesdep +QuickCheckdep +gaugedep ~basedep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, gauge

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• ChangeLog.md +22/−0
• benchmarks/BenchmarkUtils.hs +7/−0
• benchmarks/RangeSetBench.hs +161/−0
• parsley-core.cabal +23/−4
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs +3/−3
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs +17/−22
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputOps.hs +1/−1
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs +60/−50
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/PosOps.hs +178/−17
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Context.hs +26/−17
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Input.hs +74/−13
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Input/Pos.hs +251/−0
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/State.hs +4/−4
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Statics.hs +10/−9
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs +5/−1
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs +7/−6
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs +15/−13
• src/ghc/Parsley/Internal/Backend/Analysis/Coins.hs +1/−1
• src/ghc/Parsley/Internal/Backend/CodeGenerator.hs +3/−1
• src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs +4/−3
• src/ghc/Parsley/Internal/Backend/Machine/LetBindings.hs +9/−26
• src/ghc/Parsley/Internal/Backend/Machine/Types/InputCharacteristic.hs +32/−0
• src/ghc/Parsley/Internal/Common/Queue.hs +3/−2
• src/ghc/Parsley/Internal/Common/Queue/Impl.hs +11/−0
• src/ghc/Parsley/Internal/Common/QueueLike.hs +6/−0
• src/ghc/Parsley/Internal/Common/RangeSet.hs +817/−0
• src/ghc/Parsley/Internal/Common/RewindQueue.hs +3/−2
• src/ghc/Parsley/Internal/Common/RewindQueue/Impl.hs +9/−1
• src/ghc/Parsley/Internal/Core.hs +2/−0
• src/ghc/Parsley/Internal/Core/CharPred.hs +201/−0
• src/ghc/Parsley/Internal/Core/CombinatorAST.hs +2/−1
• src/ghc/Parsley/Internal/Core/Defunc.hs +26/−19
• src/ghc/Parsley/Internal/Core/Primitives.hs +2/−2
• test/CommonTest.hs +2/−0
• test/CommonTest/RangeSet.hs +154/−0
• test/Primitive.hs +9/−0
• test/Primitive/Parsers.hs +10/−3

@@ -139,3 +139,25 @@ * Added `Typeable` constraint to `LIFTED`. * Removed `lamTermBool` and `userBool` from the API: `Typeable` subsumes them. * Added `RANGES` to the `Defunc` API.++## 2.1.0.0 -- 2022-01-12++* Added `RangeSet` datastructure.+* Added `Pos` module for static manipulation of position information.+* Added `CharPred` as a specialised defunctionalisation of `Char -> Bool` functions.+* Moved `InputCharacteristic` to its own module.+* Use `CharPred` for `Sat` and `Satisfy`.+* Simplified the interface for `Ops.sat`.+* Simplified `buildYesHandler` and allowed it to capture a statically annotated offset.+* Introduced `buildIterYesHandler` which can capture static offet.+* Changed types of `bindSameHandler` and `bindIterSame`.+* Added `StaYesHandler` type to `Ops`.+* Renamed `updatePos` to `updatePosQ`.+* Added many methods for manipulating positions to `PosOps`.+* Made `initPos` fully static.+* Changed the type of `readChar`.+* Hid some internals of `Input`.+* Exposed some new methods for `Input`.+* Added `INPUT` to 8.6+ backend for `Defunc`.+* Added a `poke` method to `QueueLike`.+* Added a `charPred` converter to `Defunc`.

@@ -0,0 +1,7 @@+module BenchmarkUtils where++import Gauge.Main         (Benchmark, defaultMainWith)+import Gauge.Main.Options (Config(displayMode), defaultConfig, DisplayMode(Condensed))++condensedMain :: [Benchmark] -> IO ()+condensedMain = defaultMainWith (defaultConfig {displayMode = Condensed})

@@ -0,0 +1,161 @@+{-# LANGUAGE StandaloneDeriving, DeriveAnyClass, DeriveGeneric, BangPatterns #-}+{-# OPTIONS_GHC -ddump-simpl -ddump-to-file #-}+module Main where++import Gauge+import BenchmarkUtils++import Parsley.Internal.Common.RangeSet (RangeSet)+import Data.Set (Set)+import Test.QuickCheck++import Control.Monad+import Control.DeepSeq++import GHC.Generics (Generic)++import qualified Parsley.Internal.Common.RangeSet as RangeSet+import qualified Data.Set as Set+import qualified Data.List as List++deriving instance (Generic a, NFData a) => NFData (RangeSet a)+deriving instance Generic a => Generic (RangeSet a)+deriving instance Generic Int+deriving instance Generic Word+deriving instance Generic Char++main :: IO ()+main = do+  xss <- forM [1..10] $ \n -> generate (vectorOf (n * 10) (chooseInt (0, n * 20)))+  condensedMain [+      rangeFromList,+      rangeMemberDeleteBench,+      rangeUnionBench,+      rangeDiffBench,+      rangeIntersectBench,+      setMemberDeleteBench,+      fromListBench xss+    ]++rangeFromList :: Benchmark+rangeFromList =+  env (return (xs1, xs2, xs3, xs4)) $ \xs -> bgroup "RangeSet.fromList" [+      bench "Pathological" $ nf RangeSet.fromList (pi4_1 xs),+      bench "4 way split" $ nf RangeSet.fromList (pi4_2 xs),+      bench "Small" $ nf RangeSet.fromList (pi4_3 xs),+      bench "alphaNum" $ nf RangeSet.fromList (pi4_4 xs)+  ]++fromListBench :: [[Int]] -> Benchmark+fromListBench xss =+  bgroup "fromList" (map (makeBench (show . length)+                                    [ ("Set", nf Set.fromList)+                                    , ("RangeSet", nf RangeSet.fromList)+                                    ]) xss)++pi4_1 :: (a, b, c, d) -> a+pi4_1 (x, _, _, _) = x++pi4_2 :: (a, b, c, d) -> b+pi4_2 (_, x, _, _) = x++pi4_3 :: (a, b, c, d) -> c+pi4_3 (_, _, x, _) = x++pi4_4 :: (a, b, c, d) -> d+pi4_4 (_, _, _, x) = x++xs1, xs2, xs3 :: [Word]+xs1 = [0,2..2048]+xs2 = List.delete 1536 (List.delete 512 (List.delete 1024 [0..2048]))+xs3 = [1, 2, 3, 5, 6, 7, 8, 11, 12, 13, 14, 16, 17, 18, 19, 20, 21, 22, 23, 25]+xs4 = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['_']++ys1 = [0..2048]+ys2 = [0..27]+ys3 = ['\x00'..'\xff']++rangeMemberDeleteBench :: Benchmark+rangeMemberDeleteBench =+  env (return (RangeSet.fromList xs1,+               RangeSet.fromList xs2,+               RangeSet.fromList xs3,+               RangeSet.fromList xs4)) $ \t ->+    bgroup "RangeSet" [+      bgroup "member" [+        bench "Pathological" $ nf (f ys1) (pi4_1 t),+        bench "4 way split" $ nf (f ys1) (pi4_2 t),+        bench "Small" $ nf (f ys2) (pi4_3 t),+        bench "alphaNum" $ nf (f ys3) (pi4_4 t)+      ],+      bgroup "delete" [+        bench "Pathological" $ nf (g ys1) (pi4_1 t),+        bench "4 way split" $ nf (g ys1) (pi4_2 t),+        bench "Small" $ nf (g ys2) (pi4_3 t),+        bench "alphaNum" $ nf (g ys3) (pi4_4 t)+      ]+    ]+  where+    f ys t = List.foldl' (\ !_ y -> RangeSet.member y t) False ys+    g ys t = List.foldl' (\ !t y -> RangeSet.delete y t) t ys++setMemberDeleteBench :: Benchmark+setMemberDeleteBench =+  env (return (Set.fromList xs1,+               Set.fromList xs2,+               Set.fromList xs3,+               Set.fromList xs4)) $ \t ->+    bgroup "Set" [+            bgroup "member" [+        bench "Pathological" $ nf (f ys1) (pi4_1 t),+        bench "4 way split" $ nf (f ys1) (pi4_2 t),+        bench "Small" $ nf (f ys2) (pi4_3 t),+        bench "alphaNum" $ nf (f ys3) (pi4_4 t)+      ],+      bgroup "delete" [+        bench "Pathological" $ nf (g ys1) (pi4_1 t),+        bench "4 way split" $ nf (g ys1) (pi4_2 t),+        bench "Small" $ nf (g ys2) (pi4_3 t),+        bench "alphaNum" $ nf (g ys3) (pi4_4 t)+      ]+    ]+  where+    f ys t = List.foldl' (\ !_ y -> Set.member y t) False ys+    g ys t = List.foldl' (\ !t y -> Set.delete y t) t ys++zs1, zs2, zs3, zs4 :: RangeSet Word+zs1 = RangeSet.fromRanges [(0, 50), (100, 150), (200, 250), (300, 350), (400, 450), (475, 500)]+zs2 = RangeSet.fromRanges [(25, 75), (125, 175), (225, 275), (325, 375), (425, 475), (485, 500)]+zs3 = RangeSet.fromRanges [(51, 99), (151, 199), (251, 299), (351, 399), (451, 474)]+zs4 = RangeSet.fromRanges [(0, 125), (140, 222), (230, 240), (310, 351), (373, 381), (462, 491)]++rangeUnionBench :: Benchmark+rangeUnionBench =+  env (return (zs1, zs2, zs3, zs4)) $ \t -> bgroup "union" [+      bench "same" $ nf (RangeSet.union (pi4_1 t)) (pi4_1 t),+      bench "overlaps" $ nf (RangeSet.union (pi4_1 t)) (pi4_2 t),+      bench "disjoint" $ nf (RangeSet.union (pi4_1 t)) (pi4_3 t),+      bench "messy" $ nf (RangeSet.union (pi4_1 t)) (pi4_4 t)+  ]++rangeDiffBench :: Benchmark+rangeDiffBench =+  env (return (zs1, zs2, zs3, zs4)) $ \t -> bgroup "difference" [+      bench "same" $ nf (RangeSet.difference (pi4_1 t)) (pi4_1 t),+      bench "overlaps" $ nf (RangeSet.difference (pi4_1 t)) (pi4_2 t),+      bench "disjoint" $ nf (RangeSet.difference (pi4_1 t)) (pi4_3 t),+      bench "messy" $ nf (RangeSet.difference (pi4_1 t)) (pi4_4 t)+  ]++rangeIntersectBench :: Benchmark+rangeIntersectBench =+  env (return (zs1, zs2, zs3, zs4)) $ \t -> bgroup "intersection" [+      bench "same" $ nf (RangeSet.intersection (pi4_1 t)) (pi4_1 t),+      bench "overlaps" $ nf (RangeSet.intersection (pi4_1 t)) (pi4_2 t),+      bench "disjoint" $ nf (RangeSet.intersection (pi4_1 t)) (pi4_3 t),+      bench "messy" $ nf (RangeSet.intersection (pi4_1 t)) (pi4_4 t)+  ]++makeBench :: NFData a => (a -> String) -> [(String, a -> Benchmarkable)] -> a -> Benchmark+makeBench caseName cases x = env (return x) (\x ->+  bgroup (caseName x) (map (\(name, gen) -> bench name $ gen x) cases))

@@ -5,7 +5,7 @@ --                   | +------- breaking internal API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             2.0.0.0+version:             2.1.0.0 synopsis:            A fast parser combinator library backed by Typed Template Haskell description:         This package contains the internals of the @parsley@ package.                      .@@ -45,6 +45,7 @@                        Parsley.Internal.Common.Fresh,                        Parsley.Internal.Common.Indexed,                        Parsley.Internal.Common.QueueLike,+                       Parsley.Internal.Common.RangeSet,                        Parsley.Internal.Common.State,                        Parsley.Internal.Common.Utils,                        Parsley.Internal.Common.Vec,@@ -57,6 +58,7 @@                         Parsley.Internal.Core,                        Parsley.Internal.Core.CombinatorAST,+                       Parsley.Internal.Core.CharPred,                        Parsley.Internal.Core.Defunc,                        Parsley.Internal.Core.Identifiers,                        Parsley.Internal.Core.InputTypes,@@ -96,6 +98,7 @@                         Parsley.Internal.Backend.Machine.Types,                        Parsley.Internal.Backend.Machine.Types.Coins,+                       Parsley.Internal.Backend.Machine.Types.InputCharacteristic,                        Parsley.Internal.Backend.Machine.Types.State    if impl(ghc >= 8.10)@@ -108,8 +111,8 @@                        Parsley.Internal.Backend.Machine.Types.Input,                        Parsley.Internal.Backend.Machine.Types.Statics, -                       Parsley.Internal.Backend.Machine.Types.Input.Offset-                       --Parsley.Internal.Backend.Machine.Types.Input.Pos+                       Parsley.Internal.Backend.Machine.Types.Input.Offset,+                       Parsley.Internal.Backend.Machine.Types.Input.Pos    default-extensions:  BangPatterns                        DataKinds@@ -187,7 +190,7 @@   type:                exitcode-stdio-1.0   build-depends:       tasty-hunit, tasty-quickcheck   main-is:             CommonTest.hs-  other-modules:       CommonTest.Queue, CommonTest.RewindQueue+  other-modules:       CommonTest.Queue, CommonTest.RewindQueue, CommonTest.RangeSet  test-suite regression-test   import:              test-common@@ -195,6 +198,22 @@   build-depends:       tasty-hunit, tasty-quickcheck, containers   main-is:             RegressionTest.hs   other-modules:       Regression.Issue27++common benchmark-common+  build-depends:       base >=4.10 && <5,+                       parsley-core,+                       gauge,+                       deepseq+  hs-source-dirs:      benchmarks+  other-modules:       BenchmarkUtils+  default-language:    Haskell2010++benchmark rangeset-bench+  import:              benchmark-common+  type:                exitcode-stdio-1.0+  build-depends:       containers,+                       QuickCheck+  main-is:             RangeSetBench.hs  source-repository head   type:                git

@@ -99,9 +99,9 @@ @since 1.0.0.0 -} genDefunc :: Defunc a -> Code a-genDefunc (LAM x)    = normaliseGen x-genDefunc BOTTOM      = [||undefined||]-genDefunc (INPUT _)  = error "Cannot materialise an input in the regular way"+genDefunc (LAM x) = normaliseGen x+genDefunc BOTTOM  = [||undefined||]+genDefunc INPUT{} = error "Cannot materialise an input in the regular way"  {-| Pattern that normalises a `Lam` before returning it.

@@ -24,7 +24,7 @@ import Control.Monad                                       (forM, liftM2, liftM3, when) import Control.Monad.Reader                                (ask, asks, reader, local) import Control.Monad.ST                                    (runST)-import Parsley.Internal.Backend.Machine.Defunc             (Defunc(INPUT), pattern FREEVAR, genDefunc, ap, ap2, _if)+import Parsley.Internal.Backend.Machine.Defunc             (Defunc(INPUT, LAM), pattern FREEVAR, genDefunc, ap, ap2, _if) import Parsley.Internal.Backend.Machine.Identifiers        (MVar(..), ΦVar, ΣVar) import Parsley.Internal.Backend.Machine.InputOps           (InputDependant, InputOps(InputOps)) import Parsley.Internal.Backend.Machine.InputRep           (Rep)@@ -33,13 +33,13 @@ import Parsley.Internal.Backend.Machine.LetRecBuilder      (letRec) import Parsley.Internal.Backend.Machine.Ops import Parsley.Internal.Backend.Machine.Types              (MachineMonad, Machine(..), run)-import Parsley.Internal.Backend.Machine.PosOps             (initPos, extractCol, extractLine)+import Parsley.Internal.Backend.Machine.PosOps             (initPos) import Parsley.Internal.Backend.Machine.Types.Context import Parsley.Internal.Backend.Machine.Types.Coins        (willConsume, int)-import Parsley.Internal.Backend.Machine.Types.Input        (Input(Input, off, pos))-import Parsley.Internal.Backend.Machine.Types.Input.Offset (mkOffset)+import Parsley.Internal.Backend.Machine.Types.Input        (Input(off), mkInput, forcePos, updatePos) import Parsley.Internal.Backend.Machine.Types.State        (Γ(..), OpStack(..)) import Parsley.Internal.Common                             (Fix4, cata4, One, Code, Vec(..), Nat(..))+import Parsley.Internal.Core.CharPred                      (CharPred, lamTerm, optimisePredGiven) import Parsley.Internal.Trace                              (Trace(trace)) import System.Console.Pretty                               (color, Color(Green)) @@ -61,7 +61,7 @@         in letRec fs              nameLet              (\μ exp rs names -> buildRec μ rs (emptyCtx names) (readyMachine exp))-             (run (readyMachine (body binding)) (Γ Empty halt (Input (mkOffset [||offset||] 0) initPos) (VCons fatal VNil)) . nextUnique . emptyCtx))+             (run (readyMachine (body binding)) (Γ Empty halt (mkInput [||offset||] initPos) (VCons fatal VNil)) . nextUnique . emptyCtx))   ||]   where     nameLet :: MVar x -> String@@ -116,7 +116,7 @@ evalLift2 :: Defunc (x -> y -> z) -> Machine s o (z : xs) n r a -> MachineMonad s o (y : x : xs) n r a evalLift2 f (Machine k) = k <&> \m γ -> m (γ {operands = let Op y (Op x xs) = operands γ in Op (ap2 f x y) xs}) -evalSat :: (?ops :: InputOps (Rep o), PositionOps (Rep o), Trace) => Defunc (Char -> Bool) -> Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a+evalSat :: forall s o xs n r a. (?ops :: InputOps (Rep o), PositionOps (Rep o), Trace) => CharPred -> Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a evalSat p k@(Machine k') = do   bankrupt <- asks isBankrupt   hasChange <- asks hasCoin@@ -127,23 +127,19 @@           do check <- asks (emitCheckAndFetch . coins)              check (Machine (local spendCoin k'))   where-    satFetch :: (?ops :: InputOps (Rep o))-             => Machine s o (Char : xs) (Succ n) r a-             -> MachineMonad s o xs (Succ n) r a+    satFetch :: Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a     satFetch mk = reader $ \ctx γ ->-      sat (ap p) (readChar ctx (fetch (input γ)))-                 (continue mk γ)-                 (raise γ)+      readChar ctx p (fetch (input γ)) $ \c staOldPred staPosPred input' ctx' ->+        let staPredC' = optimisePredGiven p staOldPred+        in sat (ap (LAM (lamTerm staPredC'))) c (continue mk γ (updatePos input' c staPosPred) ctx')+                                                (raise γ) -    emitCheckAndFetch :: (?ops :: InputOps (Rep o), PositionOps (Rep o))-                      => Int-                      -> Machine s o (Char : xs) (Succ n) r a-                      -> MachineMonad s o xs (Succ n) r a+    emitCheckAndFetch :: Int -> Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a     emitCheckAndFetch n mk = do       sat <- satFetch mk       return $ \γ -> emitLengthCheck n (sat γ) (raise γ) (off (input γ)) -    continue mk γ c input' = run mk (γ {input = input', operands = Op c (operands γ)})+    continue mk γ input' ctx v = run mk (γ {input = input', operands = Op v (operands γ)}) ctx  evalEmpt :: MachineMonad s o xs (Succ n) r a evalEmpt = return $! raise@@ -156,7 +152,7 @@   Always gh (Machine h) ->     liftM2 (\mk mh γ -> bindAlwaysHandler γ gh (buildHandler γ mh u) mk) k h   Same gyes (Machine yes) gno (Machine no) ->-    liftM3 (\mk myes mno γ -> bindSameHandler γ gyes (buildYesHandler γ myes u) gno (buildHandler γ mno u) mk) k yes no+    liftM3 (\mk myes mno γ -> bindSameHandler γ gyes (buildYesHandler γ myes{- u-}) gno (buildHandler γ mno u) mk) k yes no  evalTell :: Machine s o (o : xs) n r a -> MachineMonad s o xs n r a evalTell (Machine k) = k <&> \mk γ -> mk (γ {operands = Op (INPUT (input γ)) (operands γ)})@@ -189,7 +185,7 @@         Always gh (Machine h) ->           liftM2 (\mh ctx γ -> bindIterAlways ctx μ l gh (buildHandler γ mh u1) (input γ) u2) h ask         Same gyes (Machine yes) gno (Machine no) ->-          liftM3 (\myes mno ctx γ -> bindIterSame ctx μ l gyes (buildYesHandler γ myes u1) gno (buildHandler γ mno u1) (input γ) u2) yes no ask+          liftM3 (\myes mno ctx γ -> bindIterSame ctx μ l gyes (buildIterYesHandler γ myes u1) gno (buildHandler γ mno u1) (input γ) u2) yes no ask  evalJoin :: ΦVar x -> MachineMonad s o (x : xs) n r a evalJoin φ = askΦ φ <&> resume@@ -218,10 +214,9 @@   let Op x xs = operands γ   in writeΣ σ a x (run k (γ {operands = xs})) ctx --- TODO: FREEVAR is the wrong abstraction really... evalSelectPos :: PosSelector -> Machine s o (Int : xs) n r a -> MachineMonad s o xs n r a-evalSelectPos Line (Machine k) = k <&> \m γ -> m (γ {operands = Op (FREEVAR (extractLine (pos (input γ)))) (operands γ)})-evalSelectPos Col (Machine k) = k <&> \m γ -> m (γ {operands = Op (FREEVAR (extractCol (pos (input γ)))) (operands γ)})+evalSelectPos sel (Machine k) = k <&> \m γ -> forcePos (input γ) sel $ \component input' ->+  m (γ {operands = Op (FREEVAR component) (operands γ), input = input'})  evalLogEnter :: (?ops :: InputOps (Rep o), LogHandler o, HandlerOps o)              => String -> Machine s o xs (Succ (Succ n)) r a -> MachineMonad s o xs (Succ n) r a

@@ -157,7 +157,7 @@  instance InputPrep (UArray Int Char) where   prepare qinput = [||-      let UArray _ _ (I# size#) input# = $$qinput+      let !(UArray _ _ (I# size#) input#) = $$qinput           next i# = (# C# (indexWideCharArray# input# i#), i# +# 1# #)       in (# next, \qi -> $$(intLess [||qi||] [||size#||]), 0# #)     ||]

@@ -34,7 +34,7 @@     -- *** Basic handlers and operations     fatal, raise,     -- *** Handler preparation-    buildHandler, buildYesHandler,+    buildHandler, buildYesHandler, buildIterYesHandler,     -- *** Handler binding     bindAlwaysHandler, bindSameHandler,     -- ** Continuation Operations@@ -55,38 +55,38 @@     -- ** Log Operations     logHandler, preludeString,     -- ** Convenience Types-    Ops, LogHandler, StaHandlerBuilder,+    Ops, LogHandler, StaHandlerBuilder, StaYesHandler,     -- * Re-exports from "Parsley.Internal.Backend.Machine.InputOps"     HandlerOps, JoinBuilder, RecBuilder, PositionOps, MarshalOps, LogOps   ) where -import Control.Monad                                   (liftM2)-import Control.Monad.Reader                            (ask, local)-import Control.Monad.ST                                (ST)-import Data.STRef                                      (writeSTRef, readSTRef, newSTRef)-import Data.Void                                       (Void)-import Debug.Trace                                     (trace)-import GHC.Exts                                        (Int(..), (-#))-import Language.Haskell.TH.Syntax                      (liftTyped)+import Control.Monad                                              (liftM2)+import Control.Monad.Reader                                       (ask, local)+import Control.Monad.ST                                           (ST)+import Data.STRef                                                 (writeSTRef, readSTRef, newSTRef)+import Data.Void                                                  (Void)+import Debug.Trace                                                (trace)+import GHC.Exts                                                   (Int(..), (-#))+import Language.Haskell.TH.Syntax                                 (liftTyped) import Parsley.Internal.Backend.Machine.BindingOps-import Parsley.Internal.Backend.Machine.Defunc         (Defunc(INPUT), genDefunc, _if, pattern FREEVAR)-import Parsley.Internal.Backend.Machine.Identifiers    (MVar, ΦVar, ΣVar)-import Parsley.Internal.Backend.Machine.InputOps       (PositionOps(..), LogOps(..), InputOps, next, more)-import Parsley.Internal.Backend.Machine.InputRep       (Rep)-import Parsley.Internal.Backend.Machine.Instructions   (Access(..))-import Parsley.Internal.Backend.Machine.LetBindings    (Regs(..), Metadata(failureInputCharacteristic, successInputCharacteristic), InputCharacteristic(..))-import Parsley.Internal.Backend.Machine.PosOps         (updatePos)-import Parsley.Internal.Backend.Machine.THUtils        (eta)-import Parsley.Internal.Backend.Machine.Types          (MachineMonad, Machine(..), run)+import Parsley.Internal.Backend.Machine.Defunc                    (Defunc(INPUT), genDefunc, _if, pattern FREEVAR)+import Parsley.Internal.Backend.Machine.Identifiers               (MVar, ΦVar, ΣVar)+import Parsley.Internal.Backend.Machine.InputOps                  (PositionOps(..), LogOps(..), InputOps, next, more)+import Parsley.Internal.Backend.Machine.InputRep                  (Rep)+import Parsley.Internal.Backend.Machine.Instructions              (Access(..))+import Parsley.Internal.Backend.Machine.LetBindings               (Regs(..), Metadata(failureInputCharacteristic, successInputCharacteristic))+import Parsley.Internal.Backend.Machine.THUtils                   (eta)+import Parsley.Internal.Backend.Machine.Types                     (MachineMonad, Machine(..), run) import Parsley.Internal.Backend.Machine.Types.Context-import Parsley.Internal.Backend.Machine.Types.Dynamics (DynFunc, DynCont, DynHandler)-import Parsley.Internal.Backend.Machine.Types.Input    (Input(..), Input#(..), toInput, fromInput)-import Parsley.Internal.Backend.Machine.Types.State    (Γ(..), OpStack(..))+import Parsley.Internal.Backend.Machine.Types.Dynamics            (DynFunc, DynCont, DynHandler)+import Parsley.Internal.Backend.Machine.Types.Input               (Input(..), Input#(..), toInput, fromInput, consume, chooseInput)+import Parsley.Internal.Backend.Machine.Types.InputCharacteristic (InputCharacteristic)+import Parsley.Internal.Backend.Machine.Types.State               (Γ(..), OpStack(..)) import Parsley.Internal.Backend.Machine.Types.Statics-import Parsley.Internal.Common                         (One, Code, Vec(..), Nat(..))-import System.Console.Pretty                           (color, Color(Green, White, Red, Blue))+import Parsley.Internal.Common                                    (One, Code, Vec(..), Nat(..))+import System.Console.Pretty                                      (color, Color(Green, White, Red, Blue)) -import Parsley.Internal.Backend.Machine.Types.Input.Offset as Offset (Offset(..), moveOne, moveN)+import Parsley.Internal.Backend.Machine.Types.Input.Offset as Offset (Offset(..))  {- General Operations -} {-|@@ -118,14 +118,14 @@ from the input within @γ@, executing the failure code if it does not exist or does not match. -@since 1.8.0.0+@since 2.1.0.0 -} sat :: (Defunc Char -> Defunc Bool)                        -- ^ Predicate to test the character with.-    -> ((Code Char -> Input o -> aux -> Code b) -> Code b) -- ^ The source of the character-    -> (Defunc Char -> Input o -> aux -> Code b)           -- ^ Code to execute on success.+    -> Code Char                                           -- ^ The character to test against.+    -> (Defunc Char -> Code b)                             -- ^ Code to execute on success.     -> Code b                                              -- ^ Code to execute on failure.     -> Code b-sat p src good bad = src $ \c input' aux -> let v = FREEVAR c in _if (p v) (good v input' aux) bad+sat p c good bad = let v = FREEVAR c in _if (p v) (good v) bad  {-| Consumes the next character and adjusts the offset to match.@@ -134,9 +134,8 @@ -} fetch :: (?ops :: InputOps (Rep o))       => Input o -> (Code Char -> Input o -> Code b) -> Code b-fetch input k = next (offset (off input)) $ \c offset' ->-  k c (input {off = moveOne (off input) offset',-              pos = updatePos (pos input) c})+fetch input k = next (offset (off input)) $ \c offset' -> k c (consume offset' input)+ {-| Emits a length check for a number of characters \(n\) in the most efficient way it can. It takes two continuations a @good@ and a @bad@: the @good@ is used@@ -238,14 +237,26 @@ the handler /always/ knows that the inputs are equal, so does not require both a captured and a current offset. Otherwise, is similar to `buildHandler`. -@since 1.4.0.0+@since 2.1.0.0 -} buildYesHandler :: Γ s o xs n r a                 -> (Γ s o xs n r a -> Code (ST s (Maybe a)))-                -> Word-                -> StaHandler s o a-buildYesHandler γ h u = fromStaHandler# $ \inp -> h (γ {input = toInput u inp})+                -> StaYesHandler s o a+buildYesHandler γ h inp = h (γ {input = inp}) +{-|+Converts a partially evaluated parser into a "yes" handler: this means that+the handler /always/ knows that the inputs are equal, so does not require+both a captured and a current offset. Otherwise, is similar to `buildHandler`.++@since 2.1.0.0+-}+buildIterYesHandler :: Γ s o xs n r a+                    -> (Γ s o xs n r a -> Code (ST s (Maybe a)))+                    -> Word+                    -> StaHandler s o a+buildIterYesHandler γ h u = fromStaHandler# (buildYesHandler γ h . toInput u)+ -- Handler binding {-| Wraps around `bindHandler#` to create a binding for "always" handlers, which always@@ -269,18 +280,18 @@ for the case where they are the same, the case where they differ, and the case where they are unknown (which is defined in terms of the previous two). -@since 1.4.0.0+@since 2.1.0.0 -} bindSameHandler :: forall s o xs n r a b. (HandlerOps o, PositionOps (Rep o))                 => Γ s o xs n r a                    -- ^ The state from which to capture the offset.                 -> Bool                              -- ^ Is a binding required for the matching handler?-                -> StaHandler s o a                  -- ^ The handler that handles matching input.+                -> StaYesHandler s o a               -- ^ The handler that handles matching input.                 -> Bool                              -- ^ Is a binding required for the mismatched handler?                 -> StaHandlerBuilder s o a           -- ^ The handler that handles mismatched input.                 -> (Γ s o xs (Succ n) r a -> Code b) -- ^ The parser to receive the composite handler.                 -> Code b bindSameHandler γ yesNeeded yes noNeeded no k =-  bindYesInline# yesNeeded (staHandler# yes (fromInput (input γ))) $ \qyes ->+  bindYesInline# yesNeeded (yes (input γ)) $ \qyes ->     bindHandlerInline# noNeeded (staHandler# (no (input γ))) $ \qno ->       let handler inp = [||if $$(same (offset (off (input γ))) (off# inp)) then $$qyes else $$(staHandler# qno inp)||]       in bindHandlerInline# @o True handler $ \qhandler ->@@ -357,19 +368,11 @@        -> (Γ s o (x : xs) (Succ n) r a -> Code (ST s (Maybe a))) -- ^ The return continuation to generate        -> Γ s o xs (Succ n) r a                                  --        -> Code (ST s (Maybe a))-callCC u sub k γ = callWithContinuation sub (suspend k γ (chooseOffset (successInputCharacteristic (meta sub)))) inp (handlers γ)+callCC u sub k γ = callWithContinuation sub (suspend k γ (chooseInput (successInputCharacteristic (meta sub)) u inp)) inp (handlers γ)   where     inp :: Input o     inp = input γ -    -- TODO: move to Offset module (along with Input#?)-    chooseOffset :: InputCharacteristic -> Input# o -> Input o-    chooseOffset (AlwaysConsumes n) inp#  = inp { off = moveN n (off inp) (off# inp#), pos = pos# inp# }-    -- Technically, in this case, we know the whole input is unchanged. This essentially ignores the continuation arguments-    -- hopefully GHC could optimise this better?-    chooseOffset NeverConsumes      _inp# = inp -- { off = (off inp) {offset = off# inp# }, pos = pos# inp# }-    chooseOffset MayConsume         inp#  = toInput u inp#- {- Join Point Operations -} {-| Wraps around `setupJoinPoint#` to make a join point and register it@@ -418,7 +421,7 @@ Similar to `bindIterAlways`, but builds a handler that performs in the same way as `bindSameHandler`. -@since 1.8.0.0+@since 2.1.0.0 -} bindIterSame :: forall s o a. (RecBuilder o, HandlerOps o, PositionOps (Rep o))              => Ctx s o a                  -- ^ The context to store the binding in.@@ -428,7 +431,7 @@              -> StaHandler s o a           -- ^ The handler when input is the same.              -> Bool                       -- ^ Is a binding required for the differing handler?              -> StaHandlerBuilder s o a    -- ^ The handler when input differs.-             -> Input o                   -- ^ The initial offset of the loop.+             -> Input o                    -- ^ The initial offset of the loop.              -> Word                       -- ^ The unique name of the captured offsets /and/ the iteration offset.              -> Code (ST s (Maybe a)) bindIterSame ctx μ l neededYes yes neededNo no inp u =@@ -577,3 +580,10 @@ @since 1.2.0.0 -} type StaHandlerBuilder s o a = Input o -> StaHandler s o a++{-|+A "yes-handler" that has not yet captured its offset++@since 2.1.0.0+-}+type StaYesHandler s o a = Input o -> Code (ST s (Maybe a))

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, MagicHash, UnboxedTuples, NumericUnderscores #-}+{-# OPTIONS_GHC -Wno-overflowed-literals #-} {-| Module      : Parsley.Internal.Backend.Machine.PosOps Description : Collection of platform dependent position operations@@ -11,49 +12,165 @@  @since 1.8.0.0 -}-module Parsley.Internal.Backend.Machine.PosOps (module Parsley.Internal.Backend.Machine.PosOps) where+module Parsley.Internal.Backend.Machine.PosOps (+    initPos, tabWidth,+    extractLine, extractCol,+    liftPos,+    updatePos, updatePosQ,+    updatePosNewlineOnly, updatePosNewlineOnlyQ,+    shiftLineAndSetCol, shiftCol, shiftAlignAndShiftCol,+    shiftLineAndSetColQ, shiftColQ, shiftAlignAndShiftColQ,+    toNextTab+  ) where  #include "MachDeps.h" #if WORD_SIZE_IN_BITS < 64 #define FULL_WIDTH_POSITIONS #endif +import Data.Bits                                   ( (.&.), (.|.)+#ifndef FULL_WIDTH_POSITIONS+                                                   , unsafeShiftL+#endif+                                                   ) import Parsley.Internal.Backend.Machine.Types.Base (Pos) import Parsley.Internal.Common                     (Code)-import GHC.Exts                                    (Int(..))-import GHC.Prim                                    (plusWord#, and#, or#, word2Int#,+import GHC.Exts                                    (Int(..), Word(W#))+import GHC.Prim                                    ( plusWord#, and#, or#, word2Int# #ifdef FULL_WIDTH_POSITIONS-                                                    minusWord#+                                                   , minusWord# #else-                                                    uncheckedShiftRL#+                                                   , uncheckedShiftRL# #endif                                                    )  {-|-Given a position and a character, returns the representation of the updated position.+Advances a column to the next tab column. -@since 1.8.0.0+@since 2.1.0.0 -}-updatePos :: Code Pos -> Code Char -> Code Pos-updatePos pos c = [||updatePos# $$pos $$c||]+toNextTab :: Word -> Word+toNextTab x = (x + tabWidth - 1) .&. negate tabWidth .|. 1  {-|+Given a dynamic character and a static position, produces a new dynamic position.++@since 2.1.0.0+-}+updatePos :: Code Char -> Word -> Word -> Code Pos+updatePos c line col = [||updatePos# $$(liftPos line col) $$c||]++{-|+Given a dynamic character and a static position, produces a new dynamic position.+For this variant, newlines are the only character than can affect the update.++@since 2.1.0.0+-}+updatePosNewlineOnly :: Code Char -> Word -> Code Pos+updatePosNewlineOnly c line = [||updatePos0ColNewlineOnly# $$(liftPos line 0) $$c||]++{-|+Given a dynamic character and a dynamic position, returns the representation of the updated position.++@since 2.1.0.0+-}+updatePosQ :: Code Char -> Code Pos -> Code Pos+updatePosQ c pos = [||updatePos# $$pos $$c||]++{-|+Given a dynamic character and a dynamic position, returns the representation of the updated position.+For this variant, newlines are the only character than can affect the update.++@since 2.1.0.0+-}+updatePosNewlineOnlyQ :: Code Char -> Code Pos -> Code Pos+updatePosNewlineOnlyQ c pos = [||updatePosNewlineOnly# $$pos $$c||]++{-|+Shift a static postion's column by a given amount++@since 2.1.0.0+-}+shiftCol :: Word -- ^ The amount to shift the column by+         -> Word -- ^ The line+         -> Word -- ^ The column+         -> (Word, Word)+shiftCol n line col = (line, col + n)++{-|+Shift a static line by a given amount and then set the column++@since 2.1.0.0+-}+shiftLineAndSetCol :: Word -- ^ The amount to shift the line by+                   -> Word -- ^ The new column+                   -> Word -- ^ The line+                   -> (Word, Word)+shiftLineAndSetCol n col line = (line + n, col)++{-|+Shift a static position by first adjusting the column, then aligning to a tab, then shifting further++@since 2.1.0.0+-}+shiftAlignAndShiftCol :: Word -- ^ Amount to shift column by before the tab shift+                      -> Word -- ^ Amount to shift column by after the tab shift+                      -> Word -- ^ The line+                      -> Word -- ^ The new column+                      -> (Word, Word)+shiftAlignAndShiftCol firstBy thenBy line col = (line, toNextTab (col + firstBy) + thenBy)++{-| The initial position used by the parser. This is some representation of (1, 1).  @since 1.8.0.0 -}-initPos :: Code Pos+initPos :: (Word, Word)+initPos = (1, 1) -{-# INLINEABLE updatePos# #-} {-|-Updates a given position assuming the given character was read. Tab characters are aligned to the-nearest 4th space boundary.+The size of a tab. -@since 1.8.0.0+@since 2.1.0.0 -}+tabWidth :: Num a => a+tabWidth = 4++{-# INLINEABLE updatePos# #-} updatePos# :: Pos -> Char -> Pos+{-# INLINE updatePosNewlineOnly# #-}+updatePosNewlineOnly# :: Pos -> Char -> Pos+{-# INLINEABLE updatePos0ColNewlineOnly# #-}+updatePos0ColNewlineOnly# :: Pos -> Char -> Pos  {-|+Shift a dynamic postion's column by a given amount++@since 2.1.0.0+-}+shiftColQ :: Word -- ^ The amount to shift the column by+          -> Code Pos+          -> Code Pos+{-|+Shift a dynamic line by a given amount and then set the column++@since 2.1.0.0+-}+shiftLineAndSetColQ :: Word -- ^ The amount to shift the line by+                    -> Word -- ^ The new column+                    -> Code Pos+                    -> Code Pos+{-|+Shift a dynamic position by first adjusting the column, then aligning to a tab, then shifting further++@since 2.1.0.0+-}+shiftAlignAndShiftColQ :: Word -- ^ Amount to shift column by before the tab shift+                       -> Word -- ^ Amount to shift column by after the tab shift+                       -> Code Pos+                       -> Code Pos++{-| Given the opaque representation of a position, extracts the line number out of it.  @since 1.8.0.0@@ -67,23 +184,67 @@ -} extractCol :: Code Pos -> Code Int +{-|+Converts a static position into a dynamic one.++@since 2.1.0.0+-}+liftPos :: Word -> Word -> Code Pos+ #ifndef FULL_WIDTH_POSITIONS-initPos = [|| 0x00000001_00000001## ||] +-- This is referred to directly in generated code, leave optimised primitives updatePos# pos '\n' = (pos `and#` 0xffffffff_00000000##) `plusWord#` 0x00000001_00000001## updatePos# pos '\t' = ((pos `plusWord#` 0x00000000_00000003##) `and#` 0xffffffff_fffffffc##) `or#` 0x00000000_00000001## updatePos# pos _    = pos `plusWord#` 0x00000000_00000001## +-- This is referred to directly in generated code, leave optimised primitives+updatePosNewlineOnly# pos = updatePos0ColNewlineOnly# (pos `and#` 0xffffffff_00000000##)++-- This is referred to directly in generated code, leave optimised primitives+updatePos0ColNewlineOnly# pos0Col '\n' = pos0Col `plusWord#` 0x00000001_00000000##+updatePos0ColNewlineOnly# pos0Col _ = pos0Col++shiftLineAndSetColQ n col qpos = [|| ($$qpos `and#` 0xffffffff_00000000##) `plusWord#` $$(liftPos n col) ||]+shiftColQ (W# n) qpos = [|| $$qpos `plusWord#` n ||]+shiftAlignAndShiftColQ firstBy thenBy qpos =+  let !(W# pre) = firstBy + 3 -- offset first, then add 3 to overshoot+      !(W# mask) = -4         -- constant fold this into raw literal+      !(W# post) = thenBy + 1 -- add the offset of tab boundary from power of two, then remaining positions+  in if thenBy == 0 then [|| (($$qpos `plusWord#` pre) `and#` mask) `or#` 0x00000000_00000001## ||] -- because tab widths are multiples of two+     else                [|| (($$qpos `plusWord#` pre) `and#` mask) `plusWord#` post ||]+ extractLine qpos = [||I# (word2Int# ($$qpos `uncheckedShiftRL#` 32#))||] extractCol qpos = [||I# (word2Int# ($$qpos `and#` 0x00000000_ffffffff##))||] -#else-initPos = [|| (# 1##, 1## #) ||]+liftPos line col = let !(W# p) = (line `unsafeShiftL` 32) .|. col in [||p||] +#else+-- This is referred to directly in generated code, leave optimised primitives updatePos# (# line, _ #)   '\n' = (# line `plusWord#` 1##, 1## #) updatePos# (# line, col #) '\t' = (# line, ((col `plusWord#` 3##) `and#` (0## `minusWord#` 4##)) `or#` 1## #) -- nearest tab boundary `c + (4 - (c - 1) % 4)` updatePos# (# line, col #) _    = (# line, col `plusWord#` 1## #) +-- This is referred to directly in generated code, leave optimised primitives+updatePosNewlineOnly# = updatePos0ColNewlineOnly#++-- This is referred to directly in generated code, leave optimised primitives+updatePos0ColNewlineOnly# (# line, _ #) '\n' = (# line `plusWord#` 1##, 0## #)+updatePos0ColNewlineOnly# pos           _    = pos++shiftLineAndSetColQ (W# n) (W# col) qpos = [|| case $$qpos of (# line, _ #) -> (# line `plusWord#` n, col #) ||]+shiftColQ (W# n) qpos = [|| case $$qpos of (# line, col #) -> (# line, col `plusWord#` n #) ||]+shiftAlignAndShiftColQ firstBy thenBy qpos =+  let !(W# pre) = firstBy + 3 -- offset first, then add 3 to overshoot+      !(W# mask) = -4         -- constant fold this into raw literal+      !(W# post) = thenBy + 1 -- add the offset of tab boundary from power of two, then remaining positions+  in [|| case $$qpos of+           (# line, col #) -> (# line,+             $$(if thenBy == 0 then [|| ((col `plusWord#` pre) `and#` mask) `or#` 1## ||] -- because tab widths are multiples of two+                else                [|| ((col `plusWord#` pre) `and#` mask) `plusWord#` post ||]) #) ||]+ extractLine qpos = [|| case $$qpos of (# line, _ #) -> I# (word2Int# line) ||] extractCol qpos = [|| case $$qpos of (# _, col #) -> I# (word2Int# col) ||]++liftPos (W# line) (W# col) = [||(# line, col #)||] #endif

@@ -1,7 +1,8 @@ {-# LANGUAGE DeriveAnyClass,              MagicHash,              DerivingStrategies,-             UnboxedTuples #-}+             UnboxedTuples,+             PatternSynonyms #-} {-| Module      : Parsley.Internal.Backend.Machine.Types.Context Description : Fully static context required to generate a parser@@ -69,7 +70,8 @@ import Parsley.Internal.Backend.Machine.Types.Dynamics (DynFunc, DynSubroutine) import Parsley.Internal.Backend.Machine.Types.Input    (Input) import Parsley.Internal.Backend.Machine.Types.Statics  (QSubroutine(..), StaFunc, StaSubroutine, StaCont)-import Parsley.Internal.Common                         (Queue, enqueue, dequeue, Code, RewindQueue)+import Parsley.Internal.Common                         (Queue, enqueue, dequeue, poke, Code, RewindQueue)+import Parsley.Internal.Core.CharPred                  (CharPred, pattern Item, andPred)  import qualified Data.Dependent.Map                           as DMap  ((!), insert, empty, lookup) import qualified Parsley.Internal.Common.QueueLike            as Queue (empty, null)@@ -83,14 +85,14 @@  @since 1.0.0.0 -}-data Ctx s o a = Ctx { μs         :: DMap MVar (QSubroutine s o a)     -- ^ Map of subroutine bindings.-                     , φs         :: DMap ΦVar (QJoin s o a)           -- ^ Map of join point bindings.-                     , σs         :: DMap ΣVar (Reg s)                 -- ^ Map of available registers.-                     , debugLevel :: Int                               -- ^ Approximate depth of debug combinator.-                     , coins      :: Int                               -- ^ Number of tokens free to consume without length check.-                     , offsetUniq :: Word                              -- ^ Next unique offset identifier.-                     , piggies    :: Queue Coins                       -- ^ Queue of future length check credit.-                     , knownChars :: RewindQueue (Code Char, Input o) -- ^ Characters that can be reclaimed on backtrack.+data Ctx s o a = Ctx { μs         :: !(DMap MVar (QSubroutine s o a))              -- ^ Map of subroutine bindings.+                     , φs         :: !(DMap ΦVar (QJoin s o a))                    -- ^ Map of join point bindings.+                     , σs         :: !(DMap ΣVar (Reg s))                          -- ^ Map of available registers.+                     , debugLevel :: {-# UNPACK #-} !Int                           -- ^ Approximate depth of debug combinator.+                     , coins      :: {-# UNPACK #-} !Int                           -- ^ Number of tokens free to consume without length check.+                     , offsetUniq :: {-# UNPACK #-} !Word                          -- ^ Next unique offset identifier.+                     , piggies    :: !(Queue Coins)                                -- ^ Queue of future length check credit.+                     , knownChars :: !(RewindQueue (Code Char, CharPred, Input o)) -- ^ Characters that can be reclaimed on backtrack.                      }  {-|@@ -425,25 +427,32 @@ @since 1.5.0.0 -} addChar :: Code Char -> Input o -> Ctx s o a -> Ctx s o a-addChar c o ctx = ctx { knownChars = enqueue (c, o) (knownChars ctx) }+addChar c o ctx = ctx { knownChars = enqueue (c, Item, o) (knownChars ctx) }  {-| Reads a character from the context's retrieval queue if one exists. If not, reads a character from another given source (and adds it to the rewind buffer). -@since 1.5.0.0+@since 2.1.0.0 -}-readChar :: Ctx s o a                                     -- ^ The original context.-         -> ((Code Char -> Input o -> Code b) -> Code b)  -- ^ The fallback source of input.-         -> (Code Char -> Input o -> Ctx s o a -> Code b) -- ^ The continuation that needs the read characters and updated context.+readChar :: Ctx s o a                                                             -- ^ The original context.+         -> CharPred                                                              -- ^ The predicate that this character will be tested against+         -> ((Code Char -> Input o -> Code b) -> Code b)                          -- ^ The fallback source of input.+         -> (Code Char -> CharPred -> CharPred -> Input o -> Ctx s o a -> Code b) -- ^ The continuation that needs the read characters and updated context.          -> Code b-readChar ctx fallback k+readChar ctx pred fallback k   | reclaimable = unsafeReadChar ctx k   | otherwise   = fallback $ \c o -> unsafeReadChar (addChar c o ctx) k   where     reclaimable = not (Queue.null (knownChars ctx))-    unsafeReadChar ctx k = let ((c, o), q) = dequeue (knownChars ctx) in k c o (ctx { knownChars = q })+    unsafeReadChar ctx k = let -- combine the old information with the new information, refining the predicate+                               -- This works for notFollowedBy at the /moment/ because the predicate does not cross the handler boundary...+                               -- Perhaps any that cross handler boundaries should be complemented if that ever happens.+                               updateChar (c, p, o) = (c, andPred p pred, o)+                               ((_, pOld, _), q) = poke updateChar (knownChars ctx)+                               ((c, p, o), q') = dequeue q+                           in k c pOld p o (ctx { knownChars = q' })  -- Exceptions newtype MissingDependency = MissingDependency IMVar deriving anyclass Exception

@@ -11,23 +11,33 @@  @since 1.8.0.0 -}-module Parsley.Internal.Backend.Machine.Types.Input (module Parsley.Internal.Backend.Machine.Types.Input) where+module Parsley.Internal.Backend.Machine.Types.Input (+    Input(off), Input#(..),+    mkInput, fromInput, toInput,+    consume,+    forcePos, updatePos,+    chooseInput+  ) where -import Parsley.Internal.Backend.Machine.InputRep           (Rep)-import Parsley.Internal.Backend.Machine.Types.Base         (Pos)-import Parsley.Internal.Backend.Machine.Types.Input.Offset (Offset(offset), mkOffset)---import Parsley.Internal.Backend.Machine.Types.Input.Pos    ()-import Parsley.Internal.Common.Utils                       (Code)+import Parsley.Internal.Backend.Machine.InputRep                  (Rep)+import Parsley.Internal.Backend.Machine.Types.Input.Offset        (Offset(offset), mkOffset, moveOne, moveN)+import Parsley.Internal.Backend.Machine.Types.Input.Pos           (StaPos, DynPos, toDynPos, fromDynPos, fromStaPos, force, update)+import Parsley.Internal.Backend.Machine.Types.InputCharacteristic (InputCharacteristic(..))+import Parsley.Internal.Common.Utils                              (Code)+import Parsley.Internal.Core.CharPred                             (CharPred)+import Parsley.Internal.Core.CombinatorAST                        (PosSelector)  {-| Packages known static information about offsets (via `Offset`) with static information about positions (currently unavailable). -@since 1.8.0.0+@since 2.1.0.0 -} data Input o = Input {-    off  :: Offset o,-    pos :: Code Pos+    -- | The offset contained within the input+    off  :: !(Offset o),+    -- | The position contained within the input+    pos :: !StaPos   }  {-|@@ -36,17 +46,25 @@ @since 1.8.0.0 -} data Input# o = Input# {-    off#  :: Code (Rep o),-    pos#  :: Code Pos+    off#  :: !(Code (Rep o)),+    pos#  :: !DynPos   }  {-|+Constructs an `Input` given a dynamic offset and a static position.++@since 2.1.0.0+-}+mkInput :: Code (Rep o) -> (Word, Word) -> Input o+mkInput off = Input (mkOffset off 0) . fromStaPos++{-| Strips away static information, returning the raw dynamic components.  @since 1.8.0.0 -} fromInput :: Input o -> Input# o-fromInput Input{..} = Input# (offset off) pos+fromInput Input{..} = Input# (offset off) (toDynPos pos)  {-| Given a unique identifier, forms a plainly annotated static combination of position and offset.@@ -54,4 +72,47 @@ @since 1.8.0.0 -} toInput :: Word -> Input# o -> Input o-toInput u Input#{..} = Input (mkOffset off# u) pos#+toInput u Input#{..} = Input (mkOffset off# u) (fromDynPos pos#)++{-|+Register that a character has been consumed on this input, incorporating the new dynamic offset.++@since 2.1.0.0+-}+consume :: Code (Rep o) -> Input o -> Input o+consume offset' input = input {+    off = moveOne (off input) offset'+  }++{-|+Collapse the position stored inside the input applying all updates to it. Once this has been completed,+the given `PosSelector` will be used to extract one of the line or column and return it to the given+continuation, along with the updated input post-collapse.++@since 2.1.0.0+-}+forcePos :: Input o -> PosSelector -> (Code Int -> Input o -> Code r) -> Code r+forcePos input sel k = force (pos input) sel (\dp sp -> k dp (input { pos = sp }))++{-|+Updates the position within the `Input` when a character has been consumed, providing it the+dynamic character that was produced as well as the static character-predicate that guarded it.++@since 2.1.0.0+-}+updatePos :: Input o -> Code Char -> CharPred -> Input o+updatePos input c p = input { pos = update (pos input) c p }++{-|+Given knowledge about how input has been consumed through a call boundary, this function can update+the input using statically acquired knowledge.++@since 2.1.0.0+-}+-- TODO: In future, we could adjust InputCharacteristic to provide information about the static behaviours of the positions too...+chooseInput :: InputCharacteristic -> Word -> Input o -> Input# o -> Input o+chooseInput (AlwaysConsumes n) _ inp  inp#  = inp { off = moveN n (off inp) (off# inp#), pos = fromDynPos (pos# inp#) }+-- Technically, in this case, we know the whole input is unchanged. This essentially ignores the continuation arguments+-- hopefully GHC could optimise this better?+chooseInput NeverConsumes      _ inp  _inp# = inp -- { off = (off inp) {offset = off# inp# }, pos = pos# inp# }+chooseInput MayConsume         u _inp inp#  = toInput u inp#

@@ -0,0 +1,251 @@+{-# LANGUAGE RecordWildCards, UnboxedTuples, PatternSynonyms #-}+{-|+Module      : Parsley.Internal.Backend.Machine.Types.Input.Pos+Description : Packaging of offsets and positions.+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : experimental++This module contains the machinery for manipulating position information, both in static and dynamic+forms.++@since 2.1.0.0+-}+module Parsley.Internal.Backend.Machine.Types.Input.Pos (+    StaPos, DynPos,+    fromDynPos, toDynPos, fromStaPos,+    force, update+  ) where++import Data.Bits                               ((.|.))+import Data.List                               (foldl')+import Parsley.Internal.Common.Utils           (Code)+import Parsley.Internal.Core.CharPred          (CharPred, pattern Specific, apply)+import Parsley.Internal.Core.CombinatorAST     (PosSelector(..))+import Parsley.Internal.Backend.Machine.PosOps (liftPos)++import qualified Parsley.Internal.Backend.Machine.PosOps as Ops+import qualified Parsley.Internal.Backend.Machine.Types.Base as Base (Pos)++{-|+The type-alias for dynamic positions.++@since 2.1.0.0+-}+type DynPos = Code Base.Pos++{-|+Type that represents static positions and their associated data.++@since 2.1.0.0+-}+data StaPos = StaPos {+    dynPos :: !Pos,+    alignment :: !Alignment,+    contributing :: ![StaChar]+  }++{-|+Converts a dynamic position into an unannotated static one.++@since 2.1.0.0+-}+fromDynPos :: DynPos -> StaPos+fromDynPos = mkStaPos . Dynamic++{-|+Forgets the static information found in a position and converts it into a dynamic one.++@since 2.1.0.0+-}+toDynPos :: StaPos -> DynPos+toDynPos = fromPos . collapse++{-|+Produce a static position from a given line and column pair.++@since 2.1.0.0+-}+fromStaPos :: (Word, Word) -> StaPos+fromStaPos = mkStaPos . uncurry Static++{-|+Given a static position, and a component to select, collapse the position down to its smallest form+(binding this to a let if necessary) and extract the desired component. The new, potentially rebound,+position is provided to the continuation too.++@since 2.1.0.0+-}+force :: StaPos -> PosSelector -> (Code Int -> StaPos -> Code r) -> Code r+force p sel k+  | null (contributing p) = k (extract sel (dynPos p)) p+  | otherwise = case collapse p of+    p'@Static{} -> k (extract sel p') (newPos p')+    Dynamic qpos -> [||+        let pos = $$qpos+        in $$(k (extract sel (Dynamic [||pos||])) (newPos (Dynamic [||pos||])))+      ||]+  where+    newPos pos = StaPos {+      dynPos = pos,+      alignment = updateAlignment (contributing p) (alignment p),+      contributing = []+    }+    extract Line (Dynamic pos) = Ops.extractLine pos+    extract Line (Static line _) = let line' = fromEnum line in [||line'||]+    extract Col (Dynamic pos) = Ops.extractCol pos+    extract Col (Static _ col) = let col' = fromEnum col in [||col'||]++{-|+Advance a static position accounting for the dynamic character that was last read and the+static predicate that guarded that read.++@since 2.1.0.0+-}+update :: StaPos -> Code Char -> CharPred -> StaPos+update pos c p = pos { contributing = StaChar c p : contributing pos }++{-----------------}+{-   INTERNALS   -}+{-----------------}++-- Data++-- TODO: This could be more fine-grained, for instance a partially static position.+data Pos = Static {-# UNPACK #-} !Word {-# UNPACK #-} !Word | Dynamic DynPos++data Alignment = Unknown | Unaligned {-# UNPACK #-} !Word++pattern Aligned :: Alignment+pattern Aligned = Unaligned 0++data StaChar = StaChar {+    char :: !(Code Char),+    predicate :: !CharPred+  }++data CharClass = Tab | Newline | Regular | NonNewline++data Updater = DynUpdater !DynUpdater !(Code Char)+             | StaUpdater !StaUpdater++data StaUpdater = OffsetLineAndSetCol {-# UNPACK #-} !Word {-# UNPACK #-} !Word+                | OffsetCol {-# UNPACK #-} !Word+                | OffsetAlignOffsetCol {-# UNPACK #-} !Word {-# UNPACK #-} !Word++data DynUpdater = FullUpdate+                | NoNewlineUpdate+                | NoColUpdate++-- Functions++mkStaPos :: Pos -> StaPos+mkStaPos pos = StaPos { dynPos = pos, alignment = alignment pos, contributing = [] }+  where+    alignment Dynamic{} = Unknown+    alignment (Static _ col) = Unaligned (col - 1 `mod` Ops.tabWidth)++fromPos :: Pos -> DynPos+fromPos (Static l c) = liftPos l c+fromPos (Dynamic p) = p++updateAlignment :: [StaChar] -> Alignment -> Alignment+updateAlignment cs a = foldr (updateAlignment' . knownChar . predicate) a cs+  where+    updateAlignment' Nothing           _             = Unknown+    updateAlignment' (Just Regular)    (Unaligned n) = Unaligned (n + 1 `mod` Ops.tabWidth)+    updateAlignment' (Just Regular)    Unknown       = Unknown+    updateAlignment' (Just NonNewline) _             = Unknown+    updateAlignment' _                 _             = Aligned++collapse :: StaPos -> Pos+collapse StaPos{..} = applyUpdaters dynPos (buildUpdaters alignment contributing)++updateTab :: Maybe StaUpdater -> StaUpdater+updateTab Nothing = OffsetAlignOffsetCol 0 0+updateTab (Just (OffsetLineAndSetCol n m)) = OffsetLineAndSetCol n (Ops.toNextTab m)+updateTab (Just (OffsetCol n)) = OffsetAlignOffsetCol n 0+updateTab (Just (OffsetAlignOffsetCol firstBy thenBy)) = OffsetAlignOffsetCol firstBy (toNextTabFromKnownAlignment thenBy)++updateRegular :: Maybe StaUpdater -> StaUpdater+updateRegular Nothing = OffsetCol 1+updateRegular (Just (OffsetLineAndSetCol n m)) = OffsetLineAndSetCol n (m + 1)+updateRegular (Just (OffsetCol n)) = OffsetCol (n + 1)+updateRegular (Just (OffsetAlignOffsetCol firstBy thenBy)) = OffsetAlignOffsetCol firstBy (thenBy + 1)++updateNewline :: Maybe StaUpdater -> StaUpdater+updateNewline (Just (OffsetLineAndSetCol n _)) = OffsetLineAndSetCol (n + 1) 1+updateNewline _ = OffsetLineAndSetCol 1 1++toNextTabFromKnownAlignment :: Word -> Word+toNextTabFromKnownAlignment x = (x .|. Ops.tabWidth - 1) + 1++{-| Takes the initial alignment and contributing characters and+    return the list of updaters (in order from left-to-right)+    that must be applied to update the position properly -}+buildUpdaters :: Alignment -> [StaChar] -> [Updater]+buildUpdaters alignment = applyAlignment alignment . removeDeadUpdates . uncurry combine . foldr f (Nothing, [])+  where+    -- The known initial alignment can affect the /first/ updater+    applyAlignment :: Alignment -> [Updater] -> [Updater]+    applyAlignment (Unaligned n) (StaUpdater (OffsetAlignOffsetCol firstBy thenBy) : updaters) =+      -- We know what the current alignment boundary is, so can eliminate the Align+      let pre = n + firstBy+          nextTabIn = toNextTabFromKnownAlignment pre+      in StaUpdater (OffsetCol (nextTabIn + thenBy)) : updaters+    applyAlignment _ updaters = updaters++    combine :: Maybe StaUpdater -> [Updater] -> [Updater]+    combine Nothing updaters = updaters+    combine (Just updater) updaters = StaUpdater updater : updaters++    f :: StaChar -> (Maybe StaUpdater, [Updater]) -> (Maybe StaUpdater, [Updater])+    f StaChar{..} (updater, updaters) =+      let charClass = knownChar predicate+      in case charClass of+        Just Tab        -> (Just (updateTab updater), updaters)+        Just Newline    -> (Just (updateNewline updater), updaters)+        Just Regular    -> (Just (updateRegular updater), updaters)+        Just NonNewline -> (Nothing, DynUpdater NoNewlineUpdate char : combine updater updaters)+        _               -> (Nothing, DynUpdater FullUpdate char : combine updater updaters)++    -- This function should reverse the list, and also remove any redundant updaters:+    -- when a newline is known, any updater before it is only useful for the newlines.+    removeDeadUpdates :: [Updater] -> [Updater]+    removeDeadUpdates = fst . foldl' g ([], True)+      where+        g :: ([Updater], Bool) -> Updater -> ([Updater], Bool)+        g res@(updaters, keep) updater@(DynUpdater kind c)+          | keep                              = (updater : updaters, True)+          -- If we're dropping because of lines, then a dynamic update known not to affect lines isn't needed+          | not keep, NoNewlineUpdate <- kind = res+          -- If we're dropping because of lines, then we don't need column updates+          | otherwise                         = (DynUpdater NoColUpdate c : updaters, False)+        -- This is a line updater, no tab or regular updaters matter anymore+        g (updaters, _) updater@(StaUpdater OffsetLineAndSetCol{}) = (updater : updaters, False)+        -- This a static non-line related update, we can drop it if needed+        g res@(updaters, keep) updater@StaUpdater{}+          | keep      = (updater : updaters, True)+          | otherwise = res++applyUpdaters :: Pos -> [Updater] -> Pos+applyUpdaters = foldl' applyUpdater+  where+    applyUpdater (Static line _) (DynUpdater NoColUpdate c) = Dynamic (Ops.updatePosNewlineOnly c line)+    applyUpdater (Dynamic pos) (DynUpdater NoColUpdate c)   = Dynamic (Ops.updatePosNewlineOnlyQ c pos)+    applyUpdater (Static line col) (DynUpdater _ c)         = Dynamic (Ops.updatePos c line col)+    applyUpdater (Dynamic pos) (DynUpdater _ c)             = Dynamic (Ops.updatePosQ c pos)+    applyUpdater pos (StaUpdater updater)                   = applyStaUpdater pos updater++    applyStaUpdater (Static line _)   (OffsetLineAndSetCol n m)             = uncurry Static $ Ops.shiftLineAndSetCol n m line+    applyStaUpdater (Static line col) (OffsetCol n)                         = uncurry Static $ Ops.shiftCol n line col+    applyStaUpdater (Static line col) (OffsetAlignOffsetCol firstBy thenBy) = uncurry Static $ Ops.shiftAlignAndShiftCol firstBy thenBy line col+    applyStaUpdater (Dynamic pos)     (OffsetLineAndSetCol n m)             = Dynamic $ Ops.shiftLineAndSetColQ n m pos+    applyStaUpdater (Dynamic pos)     (OffsetCol n)                         = Dynamic $ Ops.shiftColQ n pos+    applyStaUpdater (Dynamic pos)     (OffsetAlignOffsetCol firstBy thenBy) = Dynamic $ Ops.shiftAlignAndShiftColQ firstBy thenBy pos++knownChar :: CharPred -> Maybe CharClass+knownChar (Specific '\t')         = Just Tab+knownChar (Specific '\n')         = Just Newline+knownChar p | not (apply p '\n')  = Just $ if not (apply p '\t') then Regular else NonNewline+knownChar _                       = Nothing

@@ -41,8 +41,8 @@  @since 1.4.0.0 -}-data Γ s o xs n r a = Γ { operands :: OpStack xs                        -- ^ The current values available for applicative application.-                        , retCont  :: StaCont s o a r                   -- ^ The current return continuation when this parser is finished.-                        , input    :: Input o                           -- ^ The current offset into the input of the parser.-                        , handlers :: Vec n (AugmentedStaHandler s o a) -- ^ The failure handlers that are used to process failure during a parser.+data Γ s o xs n r a = Γ { operands :: !(OpStack xs)                        -- ^ The current values available for applicative application.+                        , retCont  :: !(StaCont s o a r)                   -- ^ The current return continuation when this parser is finished.+                        , input    :: !(Input o)                           -- ^ The current offset into the input of the parser.+                        , handlers :: !(Vec n (AugmentedStaHandler s o a)) -- ^ The failure handlers that are used to process failure during a parser.                         }

@@ -46,15 +46,16 @@     staSubroutine#, meta,   ) where -import Control.Monad.ST                                    (ST)-import Data.STRef                                          (STRef)-import Data.Kind                                           (Type)-import Data.Maybe                                          (fromMaybe)-import Parsley.Internal.Backend.Machine.LetBindings        (Regs(..), Metadata, newMeta, InputCharacteristic(..))-import Parsley.Internal.Backend.Machine.Types.Dynamics     (DynCont, DynHandler, DynFunc)-import Parsley.Internal.Backend.Machine.Types.Input        (Input(..), Input#(..), fromInput)-import Parsley.Internal.Backend.Machine.Types.Input.Offset (Offset, same)-import Parsley.Internal.Common.Utils                       (Code)+import Control.Monad.ST                                           (ST)+import Data.STRef                                                 (STRef)+import Data.Kind                                                  (Type)+import Data.Maybe                                                 (fromMaybe)+import Parsley.Internal.Backend.Machine.LetBindings               (Regs(..), Metadata, newMeta)+import Parsley.Internal.Backend.Machine.Types.Dynamics            (DynCont, DynHandler, DynFunc)+import Parsley.Internal.Backend.Machine.Types.Input               (Input(..), Input#(..), fromInput)+import Parsley.Internal.Backend.Machine.Types.Input.Offset        (Offset, same)+import Parsley.Internal.Backend.Machine.Types.InputCharacteristic (InputCharacteristic(..))+import Parsley.Internal.Common.Utils                              (Code)  -- Handlers {-|

@@ -11,6 +11,7 @@ data Defunc a where   LAM     :: Lam a -> Defunc a   BOTTOM  :: Defunc a+  INPUT   :: Code o -> (Code Int, Code Int) -> Defunc o   SAME    :: PositionOps o => Defunc (o -> o -> Bool)  user :: Core.Defunc a -> Defunc a@@ -20,7 +21,8 @@ ap f x = LAM (Lam.App (unliftDefunc f) (unliftDefunc x))  ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c-ap2 f x = ap (ap f x)+ap2 SAME (INPUT o1 _) (INPUT o2 _) = LAM (Lam.Var False [|| $$same $$o1 $$o2 ||])+ap2 f x y = ap (ap f x) y  _if :: Defunc Bool -> Code a -> Code a -> Code a _if c t e = normaliseGen (Lam.If (unliftDefunc c) (Lam.Var False t) (Lam.Var False e))@@ -32,6 +34,7 @@ genDefunc :: Defunc a -> Code a genDefunc (LAM x) = normaliseGen x genDefunc BOTTOM  = [||undefined||]+genDefunc INPUT{} = error "Cannot materialise an input in the regular way" genDefunc SAME    = same  pattern NormLam :: Lam a -> Defunc a@@ -45,4 +48,5 @@ instance Show (Defunc a) where   show (LAM x) = show x   show SAME = "same"+  show INPUT{} = "input"   show BOTTOM = "[[irrelevant]]"

@@ -11,7 +11,7 @@ import Control.Monad                                  (forM, liftM2) import Control.Monad.Reader                           (ask, asks, local) import Control.Monad.ST                               (runST)-import Parsley.Internal.Backend.Machine.Defunc        (Defunc(LAM, SAME), pattern FREEVAR, genDefunc, ap, ap2, _if)+import Parsley.Internal.Backend.Machine.Defunc        (Defunc(LAM, SAME, INPUT), pattern FREEVAR, genDefunc, ap, ap2, _if) import Parsley.Internal.Backend.Machine.Identifiers   (MVar(..), ΦVar, ΣVar) import Parsley.Internal.Backend.Machine.InputOps      (InputDependant(..), PositionOps, BoxOps, LogOps, InputOps(InputOps)) import Parsley.Internal.Backend.Machine.Instructions  (Instr(..), MetaInstr(..), Access(..), PosSelector(..))@@ -21,6 +21,7 @@ import Parsley.Internal.Backend.Machine.Types.Coins   (willConsume) import Parsley.Internal.Backend.Machine.Types.State import Parsley.Internal.Common                        (Fix4, cata4, One, Code, Vec(..), Nat(..))+import Parsley.Internal.Core                          (CharPred) import Parsley.Internal.Trace                         (Trace(trace)) import System.Console.Pretty                          (color, Color(Green)) @@ -91,7 +92,7 @@ evalLift2 :: Defunc (x -> y -> z) -> Machine s o (z : xs) n r a -> MachineMonad s o (y : x : xs) n r a evalLift2 f (Machine k) = k <&> \m γ -> m (γ {operands = let Op y (Op x xs) = operands γ in Op (ap2 f x y) xs}) -evalSat :: (?ops :: InputOps o, PositionOps o, BoxOps o, HandlerOps o, Trace) => Defunc (Char -> Bool) -> Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a+evalSat :: (?ops :: InputOps o, PositionOps o, BoxOps o, HandlerOps o, Trace) => CharPred -> Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a evalSat p (Machine k) = do   bankrupt <- asks isBankrupt   hasChange <- asks hasCoin@@ -99,9 +100,9 @@      | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k      | otherwise -> trace "I have a piggy :)" $ local breakPiggy (asks ((maybeEmitCheck . Just) . coins) <*> local spendCoin k)   where-    maybeEmitCheck Nothing mk γ = sat (ap p) mk (raise γ) γ+    maybeEmitCheck Nothing mk γ = sat p mk (raise γ) γ     maybeEmitCheck (Just n) mk γ =-      [|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (ap p) mk [||bad||]) [||bad||] γ)||]+      [|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat p mk [||bad||]) [||bad||] γ)||]  evalEmpt :: (BoxOps o, HandlerOps o) => MachineMonad s o xs (Succ n) r a evalEmpt = return $! raise@@ -121,10 +122,10 @@         Machine (evalChoices [LAM (Abs id)] [Machine (evalPop yes)] no)))))))  evalTell :: Machine s o (o : xs) n r a -> MachineMonad s o xs n r a-evalTell (Machine k) = k <&> \mk γ -> mk (γ {operands = Op (FREEVAR (input γ)) (operands γ)})+evalTell (Machine k) = k <&> \mk γ -> mk (γ {operands = Op (INPUT (input γ) (pos γ)) (operands γ)})  evalSeek :: Machine s o xs n r a -> MachineMonad s o (o : xs) n r a-evalSeek (Machine k) = k <&> \mk γ -> let Op input xs = operands γ in mk (γ {operands = xs, input = genDefunc input})+evalSeek (Machine k) = k <&> \mk γ -> let Op (INPUT input pos) xs = operands γ in mk (γ {operands = xs, input = input, pos = pos})  evalCase :: Machine s o (x : xs) n r a -> Machine s o (y : xs) n r a -> MachineMonad s o (Either x y : xs) n r a evalCase (Machine p) (Machine q) = liftM2 (\mp mq γ ->

@@ -19,7 +19,7 @@ import Data.Text                                     (Text) import Data.Void                                     (Void) import Debug.Trace                                   (trace)-import Parsley.Internal.Backend.Machine.Defunc       (Defunc, pattern FREEVAR, genDefunc, _if)+import Parsley.Internal.Backend.Machine.Defunc       (Defunc(LAM, INPUT), pattern FREEVAR, genDefunc, ap, _if) import Parsley.Internal.Backend.Machine.Identifiers  (MVar, ΦVar, ΣVar) import Parsley.Internal.Backend.Machine.InputOps     (PositionOps(..), BoxOps(..), LogOps(..), InputOps, next, more) import Parsley.Internal.Backend.Machine.InputRep     (Unboxed, OffWith, UnpackedLazyByteString, Stream{-, representationTypes-})@@ -28,6 +28,7 @@ import Parsley.Internal.Backend.Machine.Types.State  (Γ(..), Ctx, Handler, Machine(..), MachineMonad, Cont, Subroutine, OpStack(..), Func,                                                       run, voidCoins, insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, cachedΣ, concreteΣ, debugLevel) import Parsley.Internal.Common                       (One, Code, Vec(..), Nat(..))+import Parsley.Internal.Core.CharPred                (CharPred, lamTerm) import System.Console.Pretty                         (color, Color(Green, White, Red, Blue))  #define inputInstances(derivation) \@@ -48,10 +49,10 @@ updatePos (qline, qcol) qc k = [|| case updatePos# $$qline $$qcol $$qc of (# line', col' #) -> $$(k ([||line'||], [||col'||])) ||]  {- Input Operations -}-sat :: (?ops :: InputOps o) => (Defunc Char -> Defunc Bool) -> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))+sat :: (?ops :: InputOps o) => CharPred -> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a)) sat p k bad γ@Γ{..} = next input $ \c input' -> let v = FREEVAR c in                         updatePos pos c $ \pos' ->-                          _if (p v)+                          _if (ap (LAM (lamTerm p)) v)                               (k (γ {operands = Op v operands, input = input', pos = pos'}))                               bad @@ -65,6 +66,7 @@ {- General Operations -} dup :: Defunc x -> (Defunc x -> Code r) -> Code r dup (FREEVAR x) k = k (FREEVAR x)+dup (INPUT o pos) k = k (INPUT o pos) dup x k = [|| let !dupx = $$(genDefunc x) in $$(k (FREEVAR [||dupx||])) ||]  {-# INLINE returnST #-}@@ -98,23 +100,23 @@   buildHandler :: BoxOps o                => Γ s o xs n r a                -> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a)))-               -> Code o -> Code (Handler s o a)+               -> Code o -> (Code Int, Code Int) -> Code (Handler s o a)   fatal :: Code (Handler s o a)   raise :: BoxOps o => Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))  setupHandler :: Γ s o xs n r a-             -> (Code o -> Code (Handler s o a))+             -> (Code o -> (Code Int, Code Int) -> Code (Handler s o a))              -> (Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) setupHandler γ h k = [||-    let handler = $$(h (input γ))+    let handler = $$(h (input γ) (pos γ))     in $$(k (γ {handlers = VCons [||handler||] (handlers γ)}))   ||]  #define deriveHandlerOps(_o)                         \ instance HandlerOps _o where                         \ {                                                    \-  buildHandler γ h c = [||\(o# :: Unboxed _o) !(line :: Int) !(col :: Int) ->     \-    $$(h (γ {operands = Op (FREEVAR c) (operands γ), \+  buildHandler γ h c pos = [||\(o# :: Unboxed _o) !(line :: Int) !(col :: Int) ->     \+    $$(h (γ {operands = Op (INPUT c pos) (operands γ), \              input = [||$$box o#||], pos = ([||line||], [||col||])}))||];           \   fatal = [||\(!_) !_ !_ -> returnST Nothing ||];          \   raise γ = let VCons h _ = handlers γ               \@@ -157,7 +159,7 @@ class BoxOps o => RecBuilder o where   buildIter :: ReturnOps o             => Ctx s o a -> MVar Void -> Machine s o '[] One Void a-            -> (Code o -> Code (Handler s o a)) -> Code o -> (Code Int, Code Int) -> Code (ST s (Maybe a))+            -> (Code o -> (Code Int, Code Int) -> Code (Handler s o a)) -> Code o -> (Code Int, Code Int) -> Code (ST s (Maybe a))   buildRec  :: MVar r             -> Regs rs             -> Ctx s o a@@ -180,10 +182,10 @@ instance RecBuilder _o where                                                     \ {                                                                                \   buildIter ctx μ l h o (line, col) = let bx = box in [||                                    \-      let handler !o# !line !col = $$(h [||$$bx o#||]) line col;                                     \+      let handler !o# !line !col = $$(h [||$$bx o#||] ([||line||], [||col||]));           \           loop !o# !line !col =                                                             \         $$(run l                                                                 \-            (Γ Empty (noreturn @_o) [||$$bx o#||] ([||line||], [||col||]) (VCons [||handler o#||] VNil)) \+            (Γ Empty (noreturn @_o) [||$$bx o#||] ([||line||], [||col||]) (VCons [||handler o# line col||] VNil)) \             (voidCoins (insertSub μ [||\_ (!o#) !line !col _ -> loop o# line col||] ctx)))           \       in loop ($$unbox $$o) $$line $$col                                                      \     ||];                                                                         \@@ -199,7 +201,7 @@  {- Debugger Operations -} class (BoxOps o, PositionOps o, LogOps o) => LogHandler o where-  logHandler :: (?ops :: InputOps o) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Code o -> Code (Handler s o a)+  logHandler :: (?ops :: InputOps o) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Code o -> (Code Int, Code Int) -> Code (Handler s o a)  preludeString :: (?ops :: InputOps o, PositionOps o, LogOps o) => String -> Char -> Γ s o xs n r a -> Ctx s o a -> String -> Code String preludeString name dir γ ctx ends = [|| concat [$$prelude, $$eof, ends, '\n' : $$caretSpace, color Blue "^"] ||]@@ -222,7 +224,7 @@ #define deriveLogHandler(_o)                                                                         \ instance LogHandler _o where                                                                         \ {                                                                                                    \-  logHandler name ctx γ _ = let VCons h _ = handlers γ in [||\(!o#) ->                               \+  logHandler name ctx γ _ _ = let VCons h _ = handlers γ in [||\(!o#) ->                             \       trace $$(preludeString name '<' (γ {input = [||$$box o#||]}) ctx (color Red " Fail")) ($$h o#) \     ||];                                                                                             \ };

@@ -67,7 +67,7 @@ alg _     (Dup k)                                 = getConst4 k alg _     (Make _ _ k)                            = getConst4 k alg _     (Get _ _ k)                             = getConst4 k-alg _     (Put _ _ k)                             = getConst4 k+alg _     (Put _ _ (Const4 k))                    = first (const zero) k alg _     (SelectPos _ k)                         = getConst4 k alg _     (LogEnter _ k)                          = getConst4 k alg _     (LogExit _ k)                           = getConst4 k

@@ -66,6 +66,8 @@ pattern TryOrElse ::  k a -> k a -> Combinator (Cofree Combinator k) a pattern TryOrElse p q <- (_ :< Try (p :< _)) :<|>: (q :< _) +-- it would be nice to generate `yesSame` handler bindings for Try, perhaps a special flag?+-- relevancy analysis might help too I guess, for a more general one? rollbackHandler :: Handler o (Fix4 (Instr o)) (o : xs) (Succ n) r a rollbackHandler = Always False (In4 (Seek (In4 Empt))) @@ -118,7 +120,7 @@  shallow :: Trace => Combinator (CodeGen o a) x -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a) shallow (Pure x)      m = do return $! In4 (Push (user x) m)-shallow (Satisfy p)   m = do return $! In4 (Sat (user p) m)+shallow (Satisfy p)   m = do return $! In4 (Sat p m) shallow (pf :<*>: px) m = do pxc <- runCodeGen px (In4 (_App m)); runCodeGen pf pxc shallow (p :*>: q)    m = do qc <- runCodeGen q m; runCodeGen p (In4 (Pop qc)) shallow (p :<*: q)    m = do qc <- runCodeGen q (In4 (Pop m)); runCodeGen p qc

@@ -35,6 +35,7 @@ import Parsley.Internal.Backend.Machine.Types.Coins (Coins(Coins)) import Parsley.Internal.Common                      (IFunctor4, Fix4(In4), Const4(..), imap4, cata4, Nat(..), One, intercalateDiff) import Parsley.Internal.Core.CombinatorAST          (PosSelector(..))+import Parsley.Internal.Core.CharPred               (CharPred)  import Parsley.Internal.Backend.Machine.Defunc as Machine (Defunc, user) import Parsley.Internal.Core.Defunc            as Core    (Defunc(ID), pattern FLIP_H)@@ -73,9 +74,9 @@             -> Instr o k (y : x : xs) n r a   {-| Reads a character so long as it matches a given predicate. If it does not, or no input is available, this instruction fails. -  @since 1.0.0.0 -}-  Sat       :: Machine.Defunc (Char -> Bool) {- ^ Predicate to apply. -}-            -> k (Char : xs) (Succ n) r a    {- ^ Machine requiring read character. -}+  @since 2.1.0.0 -}+  Sat       :: CharPred                   {- ^ Predicate to apply. -}+            -> k (Char : xs) (Succ n) r a {- ^ Machine requiring read character. -}             -> Instr o k xs (Succ n) r a   {-| Calls another let-bound parser. 

@@ -12,20 +12,21 @@ @since 1.0.0.0 -} module Parsley.Internal.Backend.Machine.LetBindings (-    LetBinding(..), Metadata, InputCharacteristic(..),+    LetBinding(..), Metadata,     Regs(..),     makeLetBinding, newMeta,     successInputCharacteristic, failureInputCharacteristic,     Binding   ) where -import Prelude hiding                                (foldr)-import Data.Kind                                     (Type)-import Data.Set                                      (Set, foldr)-import Data.Some                                     (Some, pattern Some)-import Parsley.Internal.Backend.Machine.Identifiers  (ΣVar, SomeΣVar(..))-import Parsley.Internal.Backend.Machine.Instructions (Instr)-import Parsley.Internal.Common                       (Fix4, One)+import Prelude hiding                                             (foldr)+import Data.Kind                                                  (Type)+import Data.Set                                                   (Set, foldr)+import Data.Some                                                  (Some, pattern Some)+import Parsley.Internal.Backend.Machine.Identifiers               (ΣVar, SomeΣVar(..))+import Parsley.Internal.Backend.Machine.Instructions              (Instr)+import Parsley.Internal.Backend.Machine.Types.InputCharacteristic (InputCharacteristic(..))+import Parsley.Internal.Common                                    (Fix4, One)  {-| Type represents a binding, which is a completed parser that can@@ -74,24 +75,6 @@     -}     failureInputCharacteristic :: InputCharacteristic   }--{-|-Provides a way to describe how input is consumed in certain circumstances:--* The input may be always the same on all paths-* The input may always be consumed, but not the same on all paths-* The input may never be consumed in any path-* It may be inconsistent--@since 1.5.0.0--}-data InputCharacteristic = AlwaysConsumes (Maybe Word)-                         -- ^ On all paths, input must be consumed: `Nothing` when the extact-                         --   amount is inconsistent across paths.-                         | NeverConsumes-                         -- ^ On all paths, no input is consumed.-                         | MayConsume-                         -- ^ The input characteristic is unknown or inconsistent.  {-| Given a `Binding` , a set of existential `ΣVar`s, and some `Metadata`, produces a

@@ -0,0 +1,32 @@+{-|+Module      : Parsley.Internal.Backend.Machine.Types.InputCharacteristic+Description : Packaging of offsets and positions.+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : experimental++This module contains the `InputCharacteristic` datatype, that describes how bindings consume input.++@since 2.1.0.0+-}+module Parsley.Internal.Backend.Machine.Types.InputCharacteristic (+    module Parsley.Internal.Backend.Machine.Types.InputCharacteristic+  ) where++{-|+Provides a way to describe how input is consumed in certain circumstances:++* The input may be always the same on all paths+* The input may always be consumed, but not the same on all paths+* The input may never be consumed in any path+* It may be inconsistent++@since 2.1.0.0+-}+data InputCharacteristic = AlwaysConsumes (Maybe Word)+                         -- ^ On all paths, input must be consumed: `Nothing` when the extact+                         --   amount is inconsistent across paths.+                         | NeverConsumes+                         -- ^ On all paths, no input is consumed.+                         | MayConsume+                         -- ^ The input characteristic is unknown or inconsistent.

@@ -13,9 +13,9 @@ module Parsley.Internal.Common.Queue (module Queue) where  import Parsley.Internal.Common.Queue.Impl as Queue (-    Queue, empty, enqueue, dequeue, null, size, foldr, enqueueAll+    Queue, empty, enqueue, dequeue, null, size, foldr, enqueueAll, poke   )-import Parsley.Internal.Common.QueueLike  (QueueLike(empty, null, size, enqueue, dequeue, enqueueAll))+import Parsley.Internal.Common.QueueLike  (QueueLike(empty, null, size, enqueue, dequeue, enqueueAll, poke))  instance QueueLike Queue where   empty      = Queue.empty@@ -24,3 +24,4 @@   enqueue    = Queue.enqueue   dequeue    = Queue.dequeue   enqueueAll = Queue.enqueueAll+  poke       = Queue.poke

@@ -68,6 +68,17 @@   | otherwise   = error "dequeue of empty queue"  {-|+modifies the head of the queue, without removal. Returns the old head++@since 2.1.0.0+-}+poke :: (a -> a) -> Queue a -> (a, Queue a)+poke f q@(outs -> (x:outs')) = (x, q {outs = f x : outs'})+poke f q@(outs -> [])+  | insz q /= 0 = poke f (Queue (insz q) (reverse (ins q)) 0 [])+  | otherwise   = error "poke of empty queue"++{-| Is the queue empty?  @since 1.5.0.0

@@ -49,6 +49,12 @@   -}   dequeue    :: q a -> (a, q a)   {-|+  modifies the head of the queue, without removal. Returns the old head++  @since 2.1.0.0+  -}+  poke :: (a -> a) -> q a -> (a, q a)+  {-|   Adds each of the elements onto the queue, from left-to-right.    @since 1.5.0.0

@@ -0,0 +1,817 @@+{-# LANGUAGE DerivingStrategies, MagicHash, UnboxedTuples, RoleAnnotations, TypeApplications #-}+{-# OPTIONS_HADDOCK prune #-}+{-|+Module      : Parsley.Internal.Common.RangeSet+Description : Packaging of offsets and positions.+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : experimental++This module contains the implementation of an efficient set for contiguous data. It has a much+smaller memory footprint than a @Set@, and can result in asymptotically faster operations.++@since 2.1.0.0+-}+module Parsley.Internal.Common.RangeSet (+    RangeSet(..),+    empty, singleton, null, full, isSingle, extractSingle, size, sizeRanges,+    member, notMember, findMin, findMax,+    insert, delete,+    union, intersection, difference, disjoint, complement,+    isSubsetOf, isProperSubsetOf,+    allLess, allMore,+    elems, unelems, fromRanges, insertRange, fromList,+    fold,+    -- Testing+    valid+  ) where++import Prelude hiding (null)+import Control.Applicative (liftA2)++import GHC.Exts (reallyUnsafePtrEquality#, isTrue#)++{-# INLINE ptrEq #-}+ptrEq :: a -> a -> Bool+ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)++{-# INLINE range #-}+range :: Enum a => a -> a -> [a]+range l u = [l..u]++{-# INLINE diff #-}+diff :: Enum a => a -> a -> Size+diff !l !u = fromEnum u - fromEnum l + 1++type Size = Int+{-|+A @Set@ type designed for types that are `Enum` as well as `Ord`. This allows the `RangeSet` to+compress the data when it is contiguous, reducing memory-footprint and enabling otherwise impractical+operations like `complement` for `Bounded` types.++@since 2.1.0.0+-}+data RangeSet a = Fork {-# UNPACK #-} !Int {-# UNPACK #-} !Size !a !a !(RangeSet a) !(RangeSet a)+                | Tip+                deriving stock Show+type role RangeSet nominal++{-|+The empty `RangeSet`.++@since 2.1.0.0+-}+{-# INLINE empty #-}+empty :: RangeSet a+empty = Tip++{-|+A `RangeSet` containing a single value.++@since 2.1.0.0+-}+singleton :: a -> RangeSet a+singleton x = single 1 x x++{-# INLINE fork #-}+fork :: Enum a => a -> a -> RangeSet a -> RangeSet a -> RangeSet a+fork !l !u !lt !rt = forkSz (size lt + size rt + diff l u) l u lt rt++forkSz :: Size -> a -> a -> RangeSet a -> RangeSet a -> RangeSet a+forkSz !sz !l !u !lt !rt = Fork (max (height lt) (height rt) + 1) sz l u lt rt++{-# INLINE single #-}+single :: Size -> a -> a -> RangeSet a+single !sz !l !u = Fork 1 sz l u Tip Tip++{-|+Is this set empty?++@since 2.1.0.0+-}+null :: RangeSet a -> Bool+null Tip = True+null _ = False++{-|+Is this set full?++@since 2.1.0.0+-}+full :: (Eq a, Bounded a) => RangeSet a -> Bool+full Tip = False+full (Fork _ _ l u _ _) = l == minBound && maxBound == u++{-|+Does this set contain a single element?++@since 2.1.0.0+-}+isSingle :: RangeSet a -> Bool+isSingle (Fork _ 1 _ _ _ _) = True+isSingle _ = False++{-|+Possibly extract the element contained in the set if it is a singleton set.++@since 2.1.0.0+-}+extractSingle :: Eq a => RangeSet a -> Maybe a+extractSingle (Fork _ _ x y Tip Tip) | x == y = Just x+extractSingle _                               = Nothing++{-# INLINE height #-}+height :: RangeSet a -> Int+height Tip = 0+height (Fork h _ _ _ _ _) = h++{-|+Return the number of /elements/ in the set.++@since 2.1.0.0+-}+{-# INLINE size #-}+size :: RangeSet a -> Int+size Tip = 0+size (Fork _ sz _ _ _ _) = sz++{-|+Return the number of /contiguous ranges/ that populate the set.++@since 2.1.0.0+-}+sizeRanges :: RangeSet a -> Int+sizeRanges = fold (\_ _ szl szr -> szl + szr + 1) 0++{-|+Test whether or not a given value is found within the set.++@since 2.1.0.0+-}+{-# INLINEABLE member #-}+member :: forall a. Ord a => a -> RangeSet a -> Bool+member !x = go+  where+    go (Fork _ _ l u lt rt)+      | l <= x    = x <= u || go rt+      | otherwise = go lt+    go Tip = False++{-|+Test whether or not a given value is not found within the set.++@since 2.1.0.0+-}+{-# INLINEABLE notMember #-}+notMember :: Ord a => a -> RangeSet a -> Bool+notMember x = not . member x++{-# INLINE ifeq #-}+ifeq :: RangeSet a -> RangeSet a -> RangeSet a -> (RangeSet a -> RangeSet a) -> RangeSet a+ifeq !x !x' y f = if size x == size x' then y else f x'++{-|+Insert a new element into the set.++@since 2.1.0.0+-}+{-# INLINEABLE insert #-}+insert :: forall a. (Enum a, Ord a) => a -> RangeSet a -> RangeSet a+insert !x Tip = single 1 x x+insert x t@(Fork h sz l u lt rt)+  -- Nothing happens when it's already in range+  | l <= x, x <= u = t+  -- If it is adjacent to the lower, it may fuse+  | x < l, x == pred l = fuseLeft h (sz + 1) x u lt rt                    -- the equality must be guarded by an existence check+  -- Otherwise, insert and balance for left+  | x < l = ifeq lt (insert x lt) t $ \lt' -> balance (sz + 1) l u lt' rt -- cannot be biased, because fusion can shrink a tree+  -- If it is adjacent to the upper range, it may fuse+  | x == succ u = fuseRight h (sz + 1) l x lt rt                          -- we know x > u since x <= l && not x <= u+  -- Otherwise, insert and balance for right+  | otherwise = ifeq rt (insert x rt) t (balance (sz + 1) l u lt)         -- cannot be biased, because fusion can shrink a tree+  where+    {-# INLINE fuseLeft #-}+    fuseLeft !h !sz !x !u Tip !rt = Fork h sz x u lt rt+    fuseLeft h sz x u lt rt+      | (# !l, !x', lt' #) <- unsafeMaxDelete lt+      -- we know there exists an element larger than x'+      -- if x == x' or x == x' + 1, we fuse+      -- x >= x' since it is one less than x''s strict upper bound+      -- x >= x' && (x == x' || x == x' + 1) === x >= x' && x <= x' + 1+      , x <= succ x' = balanceR sz l u lt' rt+      | otherwise    = Fork h sz x u lt rt+    {-# INLINE fuseRight #-}+    fuseRight !h !sz !l !x !lt Tip = Fork h sz l x lt rt+    fuseRight h sz l x lt rt+      | (# !x', !u, rt' #) <- unsafeMinDelete rt+      -- we know there exists an element smaller than x'+      -- if x == x' or x == x' - 1, we fuse+      -- x <= x' since it is one greater than x''s strict lower bound,+      -- x <= x' && (x == x' || x == x' - 1) === x <= x' && x >= x' - 1+      , x >= pred x' = balanceL sz l u lt rt'+      | otherwise    = Fork h sz l x lt rt++{-|+Remove an element from the set, if it appears.++@since 2.1.0.0+-}+{-# INLINEABLE delete #-}+delete :: (Enum a, Ord a) => a -> RangeSet a -> RangeSet a+delete !_ Tip = Tip+delete x t@(Fork h sz l u lt rt) =+  case compare l x of+    -- If its the only part of the range, the node is removed+    EQ | x == u    -> glue (sz - 1) lt rt+    -- If it's at an extreme, it shrinks the range+       | otherwise -> Fork h (sz - 1) (succ l) u lt rt+    LT -> case compare x u of+    -- If it's at an extreme, it shrinks the range+       EQ          -> Fork h (sz - 1) l (pred u) lt rt+    -- Otherwise, if it's still in range, the range undergoes fission+       LT          -> fission (sz - 1) l x u lt rt+    -- Otherwise delete and balance for one of the left or right+       GT          -> ifeq rt (delete x rt) t $ balance (sz - 1) l u lt             -- cannot be biased, because fisson can grow a tree+    GT             -> ifeq lt (delete x lt) t $ \lt' -> balance (sz - 1) l u lt' rt -- cannot be biased, because fisson can grow a tree+  where+    {- Fission breaks a node into two new ranges+       we'll push the range down into the right arbitrarily+       To do this, we have to make it a child of the right-tree's left most position. -}+    {-# INLINE fission #-}+    fission !sz !l1 !x !u2 !lt !rt =+      let u1 = pred x+          l2 = succ x+          rt' = unsafeInsertL (diff l2 u2) l2 u2 rt+      in balanceR sz l1 u1 lt rt'++{-|+Inserts an range at the left-most position in the tree.+It *must* not overlap with any other range within the tree.+It *must* be /known/ not to exist within the tree.+-}+{-# INLINEABLE unsafeInsertL #-}+unsafeInsertL :: Size -> a -> a -> RangeSet a -> RangeSet a+unsafeInsertL !newSz l u Tip = single newSz l u+unsafeInsertL newSz l u (Fork _ sz l' u' lt rt) = balanceL (sz + newSz) l' u' (unsafeInsertL newSz l u lt) rt++{-|+Inserts an range at the right-most position in the tree.+It *must* not overlap with any other range within the tree.+It *must* be /known/ not to exist within the tree.+-}+{-# INLINEABLE unsafeInsertR #-}+unsafeInsertR :: Size -> a -> a -> RangeSet a -> RangeSet a+unsafeInsertR !newSz l u Tip = single newSz l u+unsafeInsertR newSz l u (Fork _ sz l' u' lt rt) = balanceR (sz + newSz) l' u' lt (unsafeInsertR newSz l u rt)++{-|+This deletes the left-most range of the tree.+It *must not* be used with an empty tree.+-}+{-# INLINEABLE unsafeDeleteL #-}+unsafeDeleteL :: Size -> RangeSet a -> RangeSet a+unsafeDeleteL !_ (Fork _ _ _ _ Tip rt) = rt+unsafeDeleteL szRemoved (Fork _ sz l u lt rt) = balanceR (sz - szRemoved) l u (unsafeDeleteL szRemoved lt) rt+unsafeDeleteL _ _ = error "unsafeDeleteL called on empty tree"++{-|+This deletes the right-most range of the tree.+It *must not* be used with an empty tree.+-}+{-{-# INLINEABLE unsafeDeleteR #-}+unsafeDeleteR :: Int -> RangeSet a -> RangeSet a+unsafeDeleteR !_ (Fork _ _ _ _ lt Tip) = lt+unsafeDeleteR szRemoved (Fork _ sz l u lt rt) = balanceL (sz - szRemoved) l u lt (unsafeDeleteR szRemoved rt)+unsafeDeleteR _ _ = error "unsafeDeleteR called on empty tree"-}++{-|+Find the minimum value within the set, if one exists.++@since 2.1.0.0+-}+{-# INLINE findMin #-}+findMin :: RangeSet a -> Maybe a+findMin Tip = Nothing+findMin t = let (# !m, !_ #) = unsafeMinRange t in Just m++-- | Should /not/ be called with an empty tree!+{-# INLINEABLE unsafeMinRange #-}+unsafeMinRange :: RangeSet a -> (# a, a #)+unsafeMinRange (Fork _ _ l u Tip _) = (# l, u #)+unsafeMinRange (Fork _ _ _ _ lt _) = unsafeMinRange lt+unsafeMinRange Tip = error "unsafeMinRange called on empty tree"++{-|+Find the maximum value within the set, if one exists.++@since 2.1.0.0+-}+{-# INLINE findMax #-}+findMax :: RangeSet a -> Maybe a+findMax Tip = Nothing+findMax t = let (# !_, !m #) = unsafeMaxRange t in Just m++-- | Should /not/ be called with an empty tree!+{-# INLINEABLE unsafeMaxRange #-}+unsafeMaxRange :: RangeSet a -> (# a, a #)+unsafeMaxRange (Fork _ _ l u _ Tip) = (# l, u #)+unsafeMaxRange (Fork _ _ _ _ _ rt) = unsafeMaxRange rt+unsafeMaxRange Tip = error "unsafeMaxRange called on empty tree"++{-# INLINE unsafeMinDelete #-}+unsafeMinDelete :: RangeSet a -> (# a, a, RangeSet a #)+unsafeMinDelete (Fork _ sz l u lt rt) = let (# !ml, !mu, !_, t' #) = go sz l u lt rt in (# ml, mu, t' #)+  where+    go !sz !l !u Tip !rt = (# l, u, sz - size rt, rt #)+    go sz l u (Fork _ lsz ll lu llt lrt) rt =+      let (# !ml, !mu, !msz, lt' #) = go lsz ll lu llt lrt+      in (# ml, mu, msz, balanceR (sz - msz) l u lt' rt #)+unsafeMinDelete Tip = error "unsafeMinDelete called on empty tree"++{-# INLINE unsafeMaxDelete #-}+unsafeMaxDelete :: RangeSet a -> (# a, a, RangeSet a #)+unsafeMaxDelete (Fork _ sz l u lt rt) = let (# !ml, !mu, !_, t' #) = go sz l u lt rt in (# ml, mu, t' #)+  where+    go !sz !l !u !lt Tip = (# l, u, sz - size lt, lt #)+    go sz l u lt (Fork _ rsz rl ru rlt rrt) =+      let (# !ml, !mu, !msz, rt' #) = go rsz rl ru rlt rrt+      in (# ml, mu, msz, balanceL (sz - msz) l u lt rt' #)+unsafeMaxDelete Tip = error "unsafeMaxDelete called on empty tree"++{-# INLINABLE balance #-}+balance :: Size -> a -> a -> RangeSet a -> RangeSet a -> RangeSet a+balance !sz !l !u lt rt+  | height lt > height rt + 1 = balanceL sz l u lt rt+  | height rt > height lt + 1 = balanceR sz l u lt rt+  | otherwise = forkSz sz l u lt rt++{-# NOINLINE balanceL #-}+balanceL :: Size -> a -> a -> RangeSet a -> RangeSet a -> RangeSet a+-- PRE: left grew or right shrank, difference in height at most 2 biasing to the left+balanceL !sz !l1 !u1 lt@(Fork !hlt !szl !l2 !u2 !llt !rlt) !rt+  -- both sides are equal height or off by one+  | dltrt <= 1 = forkSz sz l1 u1 lt rt+  -- The bias is 2 (dltrt == 2)+  | hllt >= hrlt = rotr sz l1 u1 lt rt+  | otherwise    = rotr sz l1 u1 (rotl szl l2 u2 llt rlt) rt+  where+    !dltrt = hlt - height rt+    !hllt = height llt+    !hrlt = height rlt+-- If the right shrank (or nothing changed), we have to be prepared to handle the Tip case for lt+balanceL sz l u Tip rt | height rt <= 1 = forkSz sz l u Tip rt+balanceL _ _ _ Tip _ = error "Right should have shrank, but is still 1 taller than a Tip!"++{-# NOINLINE balanceR #-}+balanceR :: Size -> a -> a -> RangeSet a -> RangeSet a -> RangeSet a+-- PRE: left shrank or right grew, difference in height at most 2 biasing to the right+balanceR !sz !l1 !u1 !lt rt@(Fork !hrt szr l2 u2 lrt rrt)+  -- both sides are equal height or off by one+  | drtlt <= 1 = forkSz sz l1 u1 lt rt+  -- The bias is 2 (drtlt == 2)+  | hrrt >= hlrt = rotl sz l1 u1 lt rt+  | otherwise    = rotl sz l1 u1 lt (rotr szr l2 u2 lrt rrt)+  where+    !drtlt = hrt - height lt+    !hlrt = height lrt+    !hrrt = height rrt+-- If the left shrank (or nothing changed), we have to be prepared to handle the Tip case for rt+balanceR sz l u lt Tip | height lt <= 1 = forkSz sz l u lt Tip+balanceR _ _ _ _ Tip = error "Left should have shrank, but is still 1 taller than a Tip!"++{-# INLINE rotr #-}+rotr :: Size -> a -> a -> RangeSet a -> RangeSet a -> RangeSet a+rotr !sz !l1 !u1 (Fork _ szl l2 u2 p q) !r = forkSz sz l2 u2 p (forkSz (sz - szl + size q) l1 u1 q r)+rotr _ _ _ _ _ = error "rotr on Tip"++{-# INLINE rotl #-}+rotl :: Size -> a -> a -> RangeSet a -> RangeSet a -> RangeSet a+rotl !sz !l1 !u1 !p (Fork _ szr l2 u2 q r) = forkSz sz l2 u2 (forkSz (sz - szr + size q) l1 u1 p q) r+rotl _ _ _ _ _ = error "rotr on Tip"++{-|+Unions two sets together such that if and only if an element appears in either one of the sets, it+will appear in the result set.++@since 2.1.0.0+-}+{-# INLINABLE union #-}+union :: (Enum a, Ord a) => RangeSet a -> RangeSet a -> RangeSet a+union t Tip = t+union Tip t = t+union t@(Fork _ _ l u lt rt) t' = case split l u t' of+  (# lt', rt' #)+    | ltlt' `ptrEq` lt, rtrt' `ptrEq` rt -> t+    | otherwise                          -> link l u ltlt' rtrt'+    where !ltlt' = lt `union` lt'+          !rtrt' = rt `union` rt'++{-|+Intersects two sets such that an element appears in the result if and only if it is present in both+of the provided sets.++@since 2.1.0.0+-}+{-# INLINABLE intersection #-}+intersection :: (Enum a, Ord a) => RangeSet a -> RangeSet a -> RangeSet a+intersection Tip _ = Tip+intersection _ Tip = Tip+intersection t1@(Fork _ _ l1 u1 lt1 rt1) t2 =+  case overlap of+    Tip -> unsafeMerge lt1lt2 rt1rt2+    Fork 1 sz x y _ _+      | x == l1, y == u1+      , lt1lt2 `ptrEq` lt1, rt1rt2 `ptrEq` rt1 -> t1+      | otherwise -> unsafeLink sz x y lt1lt2 rt1rt2+    Fork _ sz x y lt' rt' -> unsafeLink (sz - size lt' - size rt') x y (unsafeMerge lt1lt2 lt') (unsafeMerge rt' rt1rt2)+  where+    (# !lt2, !overlap, !rt2 #) = splitOverlap l1 u1 t2+    !lt1lt2 = intersection lt1 lt2+    !rt1rt2 = intersection rt1 rt2++{-|+Do two sets have no elements in common?++@since 2.1.0.0+-}+{-# INLINE disjoint #-}+disjoint :: (Enum a, Ord a) => RangeSet a -> RangeSet a -> Bool+disjoint Tip _ = True+disjoint _ Tip = True+disjoint (Fork _ _ l u lt rt) t = case splitOverlap l u t of+  (# lt', Tip, rt' #) -> disjoint lt lt' && disjoint rt rt'+  _                   -> False++{-|+Removes all elements from the first set that are found in the second set.++@since 2.1.0.0+-}+{-# INLINEABLE difference #-}+difference :: (Enum a, Ord a) => RangeSet a -> RangeSet a -> RangeSet a+difference Tip _ = Tip+difference t Tip = t+difference t (Fork _ _ l u lt rt) = case split l u t of+  (# lt', rt' #)+    | size lt'lt + size rt'rt == size t -> t+    | otherwise -> unsafeMerge lt'lt rt'rt+    where+      !lt'lt = difference lt' lt+      !rt'rt = difference rt' rt++{-# INLINEABLE unsafeInsertLAdj #-}+unsafeInsertLAdj :: (Enum a, Eq a) => Size -> a -> a -> RangeSet a -> RangeSet a+unsafeInsertLAdj !newSz !l !u !t = case unsafeMinRange t of+  (# !l', _ #) | l' == succ u -> unsafeFuseL newSz l t+               | otherwise    -> unsafeInsertL newSz l u t++{-# INLINEABLE unsafeInsertRAdj #-}+unsafeInsertRAdj :: (Enum a, Eq a) => Size -> a -> a -> RangeSet a -> RangeSet a+unsafeInsertRAdj !newSz !l !u !t = case unsafeMaxRange t of+  (# _, !u' #) | u' == pred l -> unsafeFuseR newSz u t+               | otherwise    -> unsafeInsertR newSz l u t++{-# INLINEABLE unsafeFuseL #-}+unsafeFuseL :: Size -> a -> RangeSet a -> RangeSet a+unsafeFuseL !newSz !l' (Fork h sz l u lt rt) = case lt of+  Tip -> Fork h (newSz + sz) l' u Tip rt+  lt  -> Fork h (newSz + sz) l u (unsafeFuseL newSz l' lt) rt+unsafeFuseL _ _ Tip = error "unsafeFuseL called on Tip"++{-# INLINEABLE unsafeFuseR #-}+unsafeFuseR :: Size -> a -> RangeSet a -> RangeSet a+unsafeFuseR !newSz !u' (Fork h sz l u lt rt) = case rt of+  Tip -> Fork h (newSz + sz) l u' lt Tip+  rt  -> Fork h (newSz + sz) l u lt (unsafeFuseR newSz u' rt)+unsafeFuseR _ _ Tip = error "unsafeFuseR called on Tip"++{-# INLINABLE link #-}+link :: (Enum a, Eq a) => a -> a -> RangeSet a -> RangeSet a -> RangeSet a+link !l !u Tip Tip = single (diff l u) l u+link l u Tip rt = unsafeInsertLAdj (diff l u) l u rt+link l u lt Tip = unsafeInsertRAdj (diff l u) l u lt+link l u lt rt = unsafeLink (diff l' u') l' u' lt'' rt''+  where+    -- we have to check for fusion up front+    (# !lmaxl, !lmaxu, lt' #) = unsafeMaxDelete lt+    (# !rminl, !rminu, rt' #) = unsafeMinDelete rt++    (# !l', !lt'' #) | lmaxu == pred l = (# lmaxl, lt' #)+                     | otherwise       = (# l, lt #)++    (# !u', !rt'' #) | rminl == succ u = (# rminu, rt' #)+                     | otherwise       = (# u, rt #)++{-# INLINEABLE unsafeLink #-}+unsafeLink :: Size -> a -> a -> RangeSet a -> RangeSet a -> RangeSet a+unsafeLink !newSz !l !u Tip rt = unsafeInsertL newSz l u rt+unsafeLink newSz l u lt Tip = unsafeInsertR newSz l u lt+unsafeLink newSz l u lt@(Fork hl szl ll lu llt lrt) rt@(Fork hr szr rl ru rlt rrt)+  | hl < hr + 1 = balanceL (newSz + szl + szr) rl ru (unsafeLink newSz l u lt rlt) rrt+  | hr < hl + 1 = balanceR (newSz + szl + szr) ll lu llt (unsafeLink newSz l u lrt rt)+  | otherwise   = forkSz (newSz + szl + szr) l u lt rt++-- This version checks for fusion between the two trees to be merged+{-{-# INLINEABLE merge #-}+merge :: (Enum a, Ord a) => RangeSet a -> RangeSet a -> RangeSet a+merge Tip Tip = Tip+merge t Tip = t+merge Tip t = t+merge t1 t2 =+  let (# !_, !u1 #) = unsafeMaxRange t1+      (# !l2, !u2, t2' #) = unsafeMinDelete t2+  in if succ u1 == l2 then unsafeMerge (unsafeFuseR (diff l2 u2) u2 t1) t2'+     else unsafeMerge t1 t2-}++-- This assumes that the trees are /totally/ disjoint+{-# INLINEABLE unsafeMerge #-}+unsafeMerge :: (Enum a, Ord a) => RangeSet a -> RangeSet a -> RangeSet a+unsafeMerge Tip rt = rt+unsafeMerge lt Tip = lt+unsafeMerge lt@(Fork hl szl ll lu llt lrt) rt@(Fork hr szr rl ru rlt rrt)+  | hl < hr + 1 = balanceL (szl + szr) rl ru (unsafeMerge lt rlt) rrt+  | hr < hl + 1 = balanceR (szl + szr) ll lu llt (unsafeMerge lrt rt)+  | otherwise   = glue (szl + szr) lt rt++-- Trees must be balanced with respect to eachother, since we pull from the tallest, no balancing is required+{-# INLINEABLE glue #-}+glue :: Size -> RangeSet a -> RangeSet a -> RangeSet a+glue !_ Tip rt = rt+glue _ lt Tip  = lt+glue sz lt rt+  | height lt < height rt = let (# !l, !u, !rt' #) = unsafeMinDelete rt in forkSz sz l u lt rt'+  | otherwise = let (# !l, !u, !lt' #) = unsafeMaxDelete lt in forkSz sz l u lt' rt++{-|+Filters a set by removing all values greater than or equal to the given value.++@since 2.1.0.0+-}+{-# INLINEABLE allLess #-}+allLess :: (Enum a, Ord a) => a -> RangeSet a -> RangeSet a+allLess !_ Tip = Tip+allLess x (Fork _ _ l u lt rt) = unsafeAllLess x l u lt rt++{-|+Filters a set by removing all values less than or equal to the given value.++@since 2.1.0.0+-}+{-# INLINEABLE allMore #-}+allMore :: (Enum a, Ord a) => a -> RangeSet a -> RangeSet a+allMore !_ Tip = Tip+allMore x (Fork _ _ l u lt rt) = unsafeAllMore x l u lt rt++{-# INLINEABLE unsafeAllLess #-}+unsafeAllLess :: (Enum a, Ord a) => a -> a -> a -> RangeSet a -> RangeSet a -> RangeSet a+unsafeAllLess !x !l !u !lt !rt = case compare x l of+  EQ          -> lt+  LT          -> allLess x lt+  GT | x <= u -> unsafeInsertR (diff l (pred x)) l (pred x) (allLess x lt)+  GT          -> link l u lt (allLess x rt)++{-# INLINEABLE unsafeAllMore #-}+unsafeAllMore :: (Enum a, Ord a) => a -> a -> a -> RangeSet a -> RangeSet a -> RangeSet a+unsafeAllMore !x !l !u !lt !rt = case compare u x of+  EQ          -> rt+  LT          -> allMore x rt+  GT | l <= x -> unsafeInsertL (diff (succ x) u) (succ x) u (allMore x rt)+  GT          -> link l u (allMore x lt) rt++{-# INLINEABLE split #-}+split :: (Enum a, Ord a) => a -> a -> RangeSet a -> (# RangeSet a, RangeSet a #)+split !_ !_ Tip = (# Tip, Tip #)+split l u (Fork _ _ l' u' lt rt)+  | u < l' = let (# !llt, !lgt #) = split l u lt in (# llt, link l' u' lgt rt #)+  | u' < l = let (# !rlt, !rgt #) = split l u rt in (# link l' u' lt rlt, rgt #)+  -- The ranges overlap in some way+  | otherwise = let !lt' = case compare l' l of+                      EQ -> lt+                      LT -> unsafeInsertR (diff l' (pred l)) l' (pred l) lt+                      GT -> allLess l lt+                    !rt' = case compare u u' of+                      EQ -> rt+                      LT -> unsafeInsertL (diff (succ u) u') (succ u) u' rt+                      GT -> allMore u rt+                in (# lt', rt' #)++{-# INLINE splitOverlap #-}+splitOverlap :: (Enum a, Ord a) => a -> a -> RangeSet a -> (# RangeSet a, RangeSet a, RangeSet a #)+splitOverlap !l !u !t = let (# lt', rt' #) = split l u t in (# lt', overlapping l u t, rt' #)++{-# INLINABLE overlapping #-}+overlapping :: (Ord a, Enum a) => a -> a -> RangeSet a -> RangeSet a+overlapping !_ !_ Tip = Tip+overlapping x y (Fork _ sz l u lt rt) =+  case compare l x of+    -- range is outside to the left+    GT -> let !lt' = overlapping x (min (pred l) y) lt+          in case cmpY of+               -- range is totally outside+               GT -> unsafeLink nodeSz l u lt' rt'+               EQ -> unsafeInsertR nodeSz l u lt'+               LT | y >= l -> unsafeInsertR (diff l y) l y lt'+               LT          -> lt'+    -- range is inside on the left+    EQ -> case cmpY of+      -- range is outside on the right+      GT -> unsafeInsertL nodeSz l u rt'+      LT -> t'+      EQ -> single nodeSz l u+    LT -> case cmpY of+      -- range is outside on the right+      GT | x <= u -> unsafeInsertL (diff x u) x u rt'+      GT          -> rt'+      _           -> t'+  where+    !cmpY = compare y u+    !nodeSz = sz - size lt - size rt+    -- leave lazy!+    rt' = overlapping (max (succ u) x) y rt+    t' = single (diff x y) x y++data StrictMaybe a = SJust !a | SNothing++{-|+Inverts a set: every value which was an element is no longer an element, and every value that+was not an element now is. This is only possible on `Bounded` types.++@since 2.1.0.0+-}+{-# INLINEABLE complement #-}+complement :: forall a. (Bounded a, Enum a, Eq a) => RangeSet a -> RangeSet a+complement Tip = single (diff @a minBound maxBound) minBound maxBound+complement t | full t = Tip+complement t@Fork{} = t'''+  where+    (# !min, !min' #) = unsafeMinRange t++    -- The complement of a tree is at most 1 larger or smaller than the original+    -- if both min and max are minBound and maxBound, it will shrink+    -- if neither min or max are minBound or maxBound, it will grow+    -- otherwise, the tree will not change size+    -- The insert or shrink will happen at an extremity, and rebalance need only occur along the spine+    (# !t', !initial #) | min == minBound = (# unsafeDeleteL (diff minBound min') t, succ min' #) -- this is safe, because we've checked for the maxSet case already+                        | otherwise       = (# t , minBound #)+    (# !t'', !final #) = go initial t'+    t''' | SJust x <- final = unsafeInsertR (diff x maxBound) x maxBound t''+         | otherwise        = t''++    safeSucc !x+      | x == maxBound = SNothing+      | otherwise     = SJust (succ x)++    -- the argument l should not be altered, it /must/ be the correct lower bound+    -- the return /must/ be the next correct lower bound+    go :: a -> RangeSet a -> (# RangeSet a, StrictMaybe a #)+    go !l Tip = (# Tip, SJust l #)+    go l (Fork _ _ u l'' lt Tip) =+      let (# !lt', SJust l' #) = go l lt+          !t' = fork l' (pred u) lt' Tip+      in  (# t', safeSucc l'' #)+    go l (Fork _ _ u l'' lt rt) =+      let (# !lt', SJust l' #) = go l lt+          (# !rt', !l''' #) = go (succ l'') rt -- this is safe, because we know the right-tree is not Tip+          !t' = fork l' (pred u) lt' rt'+      in  (# t', l''' #)++{-|+Tests if all the element of the first set appear in the second, but also that the first and second+sets are not equal.++@since 2.1.0.0+-}+{-# INLINE isProperSubsetOf #-}+isProperSubsetOf :: (Enum a, Ord a) => RangeSet a -> RangeSet a -> Bool+isProperSubsetOf t1 t2 = size t1 < size t2 && uncheckedSubsetOf t1 t2++{-|+Tests if all the elements of the first set appear in the second.++@since 2.1.0.0+-}+{-# INLINEABLE isSubsetOf #-}+isSubsetOf :: (Enum a, Ord a) => RangeSet a -> RangeSet a -> Bool+isSubsetOf t1 t2 = size t1 <= size t2 && uncheckedSubsetOf t1 t2++uncheckedSubsetOf :: (Enum a, Ord a) => RangeSet a -> RangeSet a -> Bool+uncheckedSubsetOf Tip _ = True+uncheckedSubsetOf _ Tip = False+uncheckedSubsetOf (Fork _ _ l u lt rt) t = case splitOverlap l u t of+  (# lt', Fork 1 _ x y _ _, rt' #) ->+       x == l && y == u+    && size lt <= size lt' && size rt <= size rt'+    && uncheckedSubsetOf lt lt' && uncheckedSubsetOf rt rt'+  _                              -> False++{-|+Returns all the elements found within the set.++@since 2.1.0.0+-}+{-# INLINE elems #-}+elems :: Enum a => RangeSet a -> [a]+elems t = fold (\l u lt rt -> lt . (range l u ++) . rt) id t []++{-|+Returns all the values that are not found within the set.++@since 2.1.0.0+-}+{-# INLINEABLE unelems #-}+unelems :: (Bounded a, Enum a, Eq a) => RangeSet a -> [a]+unelems t = fold fork tip t minBound maxBound []+  where+    fork l' u' lt rt l u = dxs . dys+      where+        dxs | l' == l   = id+            | otherwise = lt l (pred l')+        dys | u == u'   = id+            | otherwise = rt (succ u') u+    tip l u = (range l u ++)++{-|+Constructs a `RangeSet` given a list of ranges.++@since 2.1.0.0+-}+-- TODO: This could be better?+{-# INLINEABLE fromRanges #-}+fromRanges :: (Enum a, Ord a) => [(a, a)] -> RangeSet a+fromRanges [(x, y)] = single (diff x y) x y+fromRanges rs = foldr (uncurry insertRange) empty rs++{-|+Inserts a range into a `RangeSet`.++@since 2.1.0.0+-}+-- This could be improved, but is OK+{-# INLINE insertRange #-}+insertRange :: (Enum a, Ord a) => a -> a -> RangeSet a -> RangeSet a+insertRange l u t = let (# lt, rt #) = split l u t in link l u lt rt++{-|+Builds a `RangeSet` from a given list of elements.++@since 2.1.0.0+-}+-- TODO: This can be made better if we account for orderedness+{-# INLINE fromList #-}+fromList :: (Enum a, Ord a) => [a] -> RangeSet a+fromList = foldr insert empty++{-|+Folds a range set.++@since 2.1.0.0+-}+{-# INLINEABLE fold #-}+fold :: (a -> a -> b -> b -> b) -- ^ Function that combines the lower and upper values (inclusive) for a range with the folded left- and right-subtrees.+     -> b                       -- ^ Value to be substituted at the leaves.+     -> RangeSet a+     -> b+fold _ tip Tip = tip+fold fork tip (Fork _ _ l u lt rt) = fork l u (fold fork tip lt) (fold fork tip rt)++-- Instances+instance Eq a => Eq (RangeSet a) where+  t1 == t2 = size t1 == size t2 && ranges t1 == ranges t2+    where+      {-# INLINE ranges #-}+      ranges :: RangeSet a -> [(a, a)]+      ranges t = fold (\l u lt rt -> lt . ((l, u) :) . rt) id t []++-- Testing Utilities+valid :: (Ord a, Enum a) => RangeSet a -> Bool+valid t = balanced t && wellSized t && orderedNonOverlappingAndCompressed True t++balanced :: RangeSet a -> Bool+balanced Tip = True+balanced (Fork h _ _ _ lt rt) =+  h == max (height lt) (height rt) + 1 &&+  height rt < h &&+  abs (height lt - height rt) <= 1 &&+  balanced lt &&+  balanced rt++wellSized :: Enum a => RangeSet a -> Bool+wellSized Tip = True+wellSized (Fork _ sz l u lt rt) = sz == size lt + size rt + diff l u && wellSized lt && wellSized rt++orderedNonOverlappingAndCompressed :: (Enum a, Ord a) => Bool -> RangeSet a -> Bool+orderedNonOverlappingAndCompressed checkCompressed = bounded (const True) (const True)+  where+    bounded _ _ Tip = True+    bounded lo hi (Fork _ _ l u lt rt) =+      l <= u &&+      lo l &&+      hi u &&+      bounded lo (boundAbove l) lt &&+      bounded (boundBelow u) hi rt++    boundAbove l | checkCompressed = liftA2 (&&) (< l) (< pred l)+                 | otherwise = (< l)++    boundBelow u | checkCompressed = liftA2 (&&) (> u) (> succ u)+                 | otherwise = (> u)

@@ -13,9 +13,9 @@ module Parsley.Internal.Common.RewindQueue (module RewindQueue) where  import Parsley.Internal.Common.RewindQueue.Impl as RewindQueue (-    RewindQueue, empty, enqueue, dequeue, rewind, null, size, foldr, enqueueAll+    RewindQueue, empty, enqueue, dequeue, rewind, null, size, foldr, enqueueAll, poke   )-import Parsley.Internal.Common.QueueLike  (QueueLike(empty, null, size, enqueue, dequeue, enqueueAll))+import Parsley.Internal.Common.QueueLike  (QueueLike(empty, null, size, enqueue, dequeue, enqueueAll, poke))  instance QueueLike RewindQueue where   empty      = RewindQueue.empty@@ -24,3 +24,4 @@   enqueue    = RewindQueue.enqueue   dequeue    = RewindQueue.dequeue   enqueueAll = RewindQueue.enqueueAll+  poke       = RewindQueue.poke

@@ -18,7 +18,7 @@ import Parsley.Internal.Common.Queue.Impl as Queue (Queue(..), toList)  import qualified Parsley.Internal.Common.Queue.Impl as Queue (-    empty, enqueue, enqueueAll, dequeue, null, size, foldr+    empty, enqueue, enqueueAll, dequeue, null, size, foldr, poke   )  {-|@@ -68,6 +68,14 @@ dequeue RewindQueue{..} =   let (x, queue') = Queue.dequeue queue   in (x, RewindQueue { queue = queue', undo = x : undo, undosz = undosz + 1 })++{-|+modifies the head of the queue, without removal. Returns the old head++@since 2.1.0.0+-}+poke :: (a -> a) -> RewindQueue a -> (a, RewindQueue a)+poke f q = let (x, queue') = Queue.poke f (queue q) in (x, q { queue = queue' })  {-| Undoes the last \(n\) `dequeue` operations but /only/ if there are that many

@@ -9,10 +9,12 @@ -} module Parsley.Internal.Core (     Parser,+    module Parsley.Internal.Core.CharPred,     module Parsley.Internal.Core.Defunc,     module Parsley.Internal.Core.InputTypes   ) where +import Parsley.Internal.Core.CharPred (CharPred) import Parsley.Internal.Core.Defunc hiding (lamTerm) import Parsley.Internal.Core.InputTypes import Parsley.Internal.Core.Primitives (Parser)

@@ -0,0 +1,201 @@+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-|+Module      : Parsley.Internal.Core.CharPred+Description : Packaging of offsets and positions.+License     : BSD-3-Clause+Maintainer  : Jamie Willis+Stability   : experimental++This module contains `CharPred`, a specialised defunctionalising for @Char -> Bool@ functions.+This can be used to efficiently query for character class membership.++@since 2.1.0.0+-}+module Parsley.Internal.Core.CharPred (+    CharPred(..), pattern Item, pattern Specific,+    apply, andPred, orPred, diffPred, optimisePredGiven,+    members, nonMembers,+    lamTerm+  ) where++import Prelude hiding (null)++import Parsley.Internal.Common.RangeSet (RangeSet, elems, unelems, fromRanges, full, member, fold, null, union, extractSingle, singleton, intersection, difference, isSubsetOf, sizeRanges)+import Parsley.Internal.Core.Lam        (Lam(Abs, App, Var, T, F, If))++{-|+Represents @Char -> Bool@ functions, potentially in a more inspectable way.++@since 2.1.0.0+-}+data CharPred where+  -- | This is a raw user-defined predicate, with little inspectability other than membership.+  UserPred :: (Char -> Bool) -> Lam (Char -> Bool) -> CharPred+  -- | This accounts for a character-class, implemented using a `RangeSet` for efficient querying and space.+  Ranges :: RangeSet Char -> CharPred++{-|+Represents @const True@.++@since 2.1.0.0+-}+pattern Item :: CharPred+pattern Item <- Ranges (full -> True)+  where Item = Ranges (fromRanges [(minBound, maxBound)])++{-|+Represents @(== c)@ for some specific @c@.++@since 2.1.0.0+-}+pattern Specific :: Char -> CharPred+pattern Specific c <- Ranges (extractSingle -> Just c)+  where Specific c = Ranges (singleton c)++{-|+Tests whether a given character falls within the predicate.++@since 2.1.0.0+-}+apply :: CharPred -> Char -> Bool+apply (UserPred f _) c = f c+apply (Ranges rngs) c = member c rngs++{-|+Merges two predicates by creating one which only returns true when a character+is in both original predicates.++@since 2.1.0.0+-}+andPred :: CharPred -> CharPred -> CharPred+andPred (UserPred f lf) p = UserPred (\c -> f c && apply p c) (Abs $ \c -> andLam (App lf c) (App (lamTerm p) c))+andPred p (UserPred f lf) = UserPred (\c -> apply p c && f c) (Abs $ \c -> andLam (App (lamTerm p) c) (App lf c))+andPred (Ranges rngs1) (Ranges rngs2) = Ranges (rngs1 `intersection` rngs2)++{-|+Occasionally, characters can pass through a predicate only to pass through another at a later point.+This given information can be used to optimise the new predicate the character is fed through.++This works as follows:+  * If the given knowledge is a subset of the new predicate, then we /know/ that any character check+    will have passed, because it already passed a stricter check. The predicate can, therefore, be+    optimised to `Item`.+  * Otherwise, the character can only pass through both predicates if it can pass through their+    intersection. If the intersection is smaller (in terms of the number of checks required to+    establish membership), then it should be used as it generates smaller code.+  * If neither of the above conditions are true, then the original predicate remains the most+    efficient for future tests.++@since 2.1.0.0+-}+optimisePredGiven :: CharPred -- ^ A predicate to be optimised with previous given knowledge.+                  -> CharPred -- ^ A predicate that is known to already be true.+                  -> CharPred+optimisePredGiven (Ranges pred) (Ranges given)+  | isSubsetOf given pred = Item+  | sizeRanges inter <= sizeRanges pred = Ranges inter+  | otherwise = Ranges pred+  where+    inter = intersection given pred+optimisePredGiven p _ = p++{-|+Merges two predicates by creating one which only returns true when a character+is in either of the original predicates.++@since 2.1.0.0+-}+orPred :: CharPred -> CharPred -> CharPred+orPred (UserPred f lf) p = UserPred (\c -> f c || apply p c) (Abs $ \c -> orLam (App lf c) (App (lamTerm p) c))+orPred p (UserPred f lf) = UserPred (\c -> apply p c || f c) (Abs $ \c -> orLam (App (lamTerm p) c) (App lf c))+orPred (Ranges rngs1) (Ranges rngs2) = Ranges (rngs1 `union` rngs2)++{-|+Merges two predicates by creating one which only returns true when a character+is in the first but not the second predicate.++@since 2.1.0.0+-}+diffPred :: CharPred -> CharPred -> CharPred+diffPred (UserPred f lf) p = UserPred (\c -> f c && not (apply p c)) (Abs $ \c -> andLam (App lf c) (notLam (App (lamTerm p) c)))+diffPred p (UserPred f lf) = UserPred (\c -> apply p c && not (f c)) (Abs $ \c -> andLam (App (lamTerm p) c) (notLam (App lf c)))+diffPred (Ranges rngs1) (Ranges rngs2) = Ranges (rngs1 `difference` rngs2)++{-|+Given a predicate, returns the full range of characters it returns @True@ for.++@since 2.1.0.0+-}+members :: CharPred -> [Char]+members (UserPred f _) = filter f [minBound..maxBound]+members (Ranges rngs)  = elems rngs++{-|+Given a predicate, returns the full range of characters it returns @False@ for.++@since 2.1.0.0+-}+nonMembers :: CharPred -> [Char]+nonMembers (UserPred f _)      = filter (not . f) [minBound..maxBound]+nonMembers (Ranges rngs)       = unelems rngs++{-|+Converts this predicate into a `Lam` term represention. This representation can+be optimised.++@since 2.1.0.0+-}+lamTerm :: CharPred -> Lam (Char -> Bool)+lamTerm (UserPred _ t) = t+lamTerm Item = Abs (const T)+lamTerm (Ranges (null -> True)) = Abs (const F)+lamTerm (Ranges rngs) =+  Abs $ \c ->+    fold (conv c) F rngs+  where+    conv c l u lb rb+    --  | l == u = eq c (Var True [||l||]) `or` (lb `or` rb)+    --  | otherwise = (lte (Var True [||l||]) c `and` lte c (Var True [||u||])) `or` (lb `or` rb)+      | l == u        = eq c (Var True [||l||]) `or` if' (lt c (Var True [||l||])) lb rb+      -- the left can be omitted here+      | l == minBound = lte c (Var True [||u||]) `or` rb+      -- the right can be omitted here+      | u == maxBound = lte (Var True [||l||]) c `or` lb+      | otherwise     = if' (lte (Var True [||l||]) c) (lte c (Var True [||u||]) `or` rb) lb++    or = orLam+    and = andLam+    lte :: Lam Char -> Lam Char -> Lam Bool+    lte = App . App (Var True [||(<=)||])+    lt :: Lam Char -> Lam Char -> Lam Bool+    lt = App . App (Var True [||(<)||])+    eq :: Lam Char -> Lam Char -> Lam Bool+    eq = App . App (Var True [||(==)||])+    if' x y F = and x y+    if' c x y = If c x y++instance Show CharPred where+  show (UserPred _ f) = show f+  show Item = "const True"+  show (Specific c) = concat ["(== ", show c, ")"]+  show (Ranges rngs) = "elem " ++ show rngs+++andLam :: Lam Bool -> Lam Bool -> Lam Bool+andLam T y = y+andLam x T = x+andLam F _ = F+andLam _ F = F+andLam x y = App (App (Var True [||(&&)||]) x) y++orLam :: Lam Bool -> Lam Bool -> Lam Bool+orLam T _ = T+orLam _ T = T+orLam F y = y+orLam y F = y+orLam x y = App (App (Var True [||(||)||]) x) y++notLam :: Lam Bool -> Lam Bool+notLam T = F+notLam F = T+notLam x = App (Var True [||not||]) x

@@ -4,6 +4,7 @@ import Data.Kind                         (Type) import Parsley.Internal.Common           (IFunctor(..), Fix, Const1(..), cata, intercalateDiff, (:+:)) import Parsley.Internal.Core.Identifiers (MVar, ΣVar)+import Parsley.Internal.Core.CharPred    (CharPred) import Parsley.Internal.Core.Defunc      (Defunc)  {-|@@ -16,7 +17,7 @@ -- Core datatype data Combinator (k :: Type -> Type) (a :: Type) where   Pure           :: Defunc a -> Combinator k a-  Satisfy        :: Defunc (Char -> Bool) -> Combinator k Char+  Satisfy        :: CharPred -> Combinator k Char   (:<*>:)        :: k (a -> b) -> k a -> Combinator k b   (:*>:)         :: k a -> k b -> Combinator k b   (:<*:)         :: k a -> k b -> Combinator k a

@@ -14,15 +14,18 @@ module Parsley.Internal.Core.Defunc (     Defunc(..),     pattern COMPOSE_H, pattern FLIP_H, pattern FLIP_CONST, pattern UNIT,-    lamTerm+    lamTerm, charPred   ) where -import Data.List                     (intercalate)-import Data.Typeable                 (Typeable, (:~:)(Refl), eqT)-import Language.Haskell.TH.Syntax    (Lift(..))-import Parsley.Internal.Common.Utils (WQ(..), Code, Quapplicative(..))-import Parsley.Internal.Core.Lam     (normaliseGen, Lam(..))+import Data.Typeable                    (Typeable, (:~:)(Refl), eqT)+import Language.Haskell.TH.Syntax       (Lift(..))+import Parsley.Internal.Common.RangeSet (fromRanges, empty, complement)+import Parsley.Internal.Common.Utils    (WQ(..), Code, Quapplicative(..))+import Parsley.Internal.Core.CharPred   (CharPred(..), pattern Item, pattern Specific)+import Parsley.Internal.Core.Lam        (normaliseGen, Lam(..)) +import qualified Parsley.Internal.Core.CharPred as CharPred (lamTerm)+ {-| This datatype is useful for providing an /inspectable/ representation of common Haskell functions. These can be provided in place of `WQ` to any combinator that requires it. The only difference is@@ -159,22 +162,26 @@ lamTerm EMPTY = Var True [||[]||] lamTerm CONST = Abs (Abs . const) lamTerm (BLACK x) = Var False (_code x)-lamTerm (RANGES incl []) = Abs (const (if incl then F else T))-lamTerm (RANGES incl [(l, u)]) | l == minBound, u == maxBound = Abs (const (if incl then T else F))-lamTerm (RANGES incl rngs) =-  Abs $ \c ->-    App (if incl then Abs id else Var True [||not||])-        (foldr1 (App . App (Var True [||(||)||]))-          (map (\(l, u) ->-            if l == u then App (App (Var True [||(==)||]) c) (Var True [||l||])-                      else App (App (Var True [||(&&)||])-                               (App (App (Var True [||(<=)||]) (Var True [||l||])) c))-                               (App (App (Var True [||(<=)||]) c) (Var True [||u||])))-           rngs))+lamTerm rngs@(RANGES _ _) = CharPred.lamTerm (charPred rngs) lamTerm (LAM_S f) = Abs (adaptLam f) lamTerm (IF_S c t e) = If (lamTerm c) (lamTerm t) (lamTerm e) lamTerm (LET_S x f) = Let (lamTerm x) (adaptLam f) +{-|+Converts a `Defunc` value into an equivalent `CharPred` value.++@since 2.1.0.0+-}+charPred :: Defunc (Char -> Bool) -> CharPred+charPred (EQ_H (LIFTED c)) = Specific c+charPred (RANGES False []) = Item+charPred (RANGES True [(l, u)]) | l == minBound, u == maxBound = Item+charPred (RANGES True cs) = Ranges (fromRanges cs)+charPred (RANGES False cs) = Ranges (complement (fromRanges cs))+charPred (APP_H CONST (LIFTED True)) = Item+charPred (APP_H CONST (LIFTED False)) = Ranges empty+charPred p = UserPred (_val p) (lamTerm p)+ adaptLam :: (Defunc a -> Defunc b) -> (Lam a -> Lam b) adaptLam f = lamTerm . f . defuncTerm   where@@ -204,5 +211,5 @@   show CONST = "const"   show (IF_S c b e) = concat ["(if ", show c, " then ", show b, " else ", show e, ")"]   show (LAM_S _) = "f"-  show (RANGES incl rngs) = concat [if incl then "not " else "", "elem (", intercalate " ++ " (map (\(l, u) -> concat ["[", show l, "..", show u, "]"]) rngs), ")"]+  show p@(RANGES{}) = show (charPred p)   show _ = "x"

@@ -7,7 +7,7 @@  import Prelude hiding                      (pure, (<*>)) import Parsley.Internal.Core.CombinatorAST (Combinator(..), ScopeRegister(..), Reg(..), Parser(..), PosSelector(..))-import Parsley.Internal.Core.Defunc        (Defunc)+import Parsley.Internal.Core.Defunc        (Defunc, charPred)  import Parsley.Internal.Common.Indexed     (Fix(In), (:+:)(..)) @@ -18,7 +18,7 @@  {-# INLINE satisfy #-} satisfy :: Defunc (Char -> Bool) -> Parser Char-satisfy = Parser . In . L . Satisfy+satisfy = Parser . In . L . Satisfy . charPred  {-# INLINE conditional #-} conditional :: [(Defunc (a -> Bool), Parser b)] -> Parser a -> Parser b -> Parser b

@@ -3,6 +3,7 @@ import Test.Tasty import qualified CommonTest.Queue as QueueTest import qualified CommonTest.RewindQueue as RewindQueueTest+import qualified CommonTest.RangeSet as RangeSetTest  main :: IO () main = defaultMain tests@@ -10,4 +11,5 @@ tests :: TestTree tests = testGroup "Common Tests" [ QueueTest.tests                                  , RewindQueueTest.tests+                                 , RangeSetTest.tests                                  ]

@@ -0,0 +1,154 @@+{-# LANGUAGE TypeApplications, StandaloneDeriving, DeriveGeneric, MonoLocalBinds #-}+module CommonTest.RangeSet where+import Test.Tasty (testGroup, TestTree)+import Test.Tasty.HUnit ( testCase, (@?=) )+import Test.Tasty.QuickCheck+  ( listOf, chooseEnum,+    (===),+    (==>),+    (.&&.),+    property,+    testProperty,+    elements,+    forAll,+    genericShrink,+    Arbitrary(arbitrary, shrink),+    Property )++import Prelude hiding (null)++import Parsley.Internal.Common.RangeSet+import Data.List (nub, sort, intersect)+import GHC.Generics (Generic)++import Data.Word (Word8)++deriving instance Generic (RangeSet a)++data Digit = Zero | One | Two | Three | Four | Five | Six | Seven | Eight | Nine deriving (Ord, Eq, Enum, Bounded, Show, Generic)++instance (Arbitrary a, Enum a, Ord a) => Arbitrary (RangeSet a) where+  arbitrary = fmap fromList (listOf arbitrary)+  shrink = filter valid . genericShrink++instance Arbitrary Digit where+  arbitrary = chooseEnum (Zero, Nine)+  shrink Zero = []+  shrink n = [Zero .. pred n]++tests :: TestTree+tests = testGroup "RangeSet" [+    testProperty "arbitrary RangeSets should be valid" $ valid @Word,+    emptyTests,+    memberTests,+    insertTests,+    deleteTests,+    fromListTests,+    testProperty "elems and unelems shoudld be disjoint" $ elemUnelemDisjoint @Word8,+    testProperty "complement . complement = id" $ complementInverse @Digit,+    testProperty "unelems == elems . complement" $ complementElemsInverse @Digit,+    testProperty "findMin should find the minimum" $ findMinMinimum @Word,+    testProperty "findMax should find the maximum" $ findMaxMaximum @Int,+    testProperty "allLess should find everything strictly less than a value" $ allLessMin @Word,+    testProperty "allMore should find everything strictly more than a value" $ allMoreMax @Word,+    testProperty "union should union" $ uncurry (unionProperty @Int),+    testProperty "intersection should intersect" $ uncurry (intersectionProperty @Digit),+    testProperty "difference should differentiate" $ uncurry (differenceProperty @Word)+  ]++emptyTests :: TestTree+emptyTests = testGroup "empty should" [+    testCase "be null" $ null empty @?= True,+    testCase "have size 0" $ size @Int empty @?= 0+  ]++-- member, notMember+memberTests :: TestTree+memberTests = testGroup "member should" [+    testCase "work when out of range" $ notMember 5 (fromRanges [(0, 4), (6, 9)]) @?= True,+    testCase "work when in range" $ member 5 (fromRanges [(0, 9)]) @?= True,+    testCase "work for exact" $ member 5 (fromRanges [(5, 5)]) @?= True,+    testProperty "perform like elem on elems" $ uncurry (memberElemProperty @Word)+  ]++-- insert+insertTests :: TestTree+insertTests =+  let t = fromList [6, 2, 7, 1, 5] -- 1-2, 5-7+  in testGroup "insert should" [+    testCase "add something in" $ member 3 (insert 3 t) @?= True,+    testCase "not affect membership for other items" $ member 4 (insert 3 t) @?= False,+    testCase "not remove membership" $ member 5 (insert 4 (insert 3 t)) @?= True+  ]++-- delete+deleteTests :: TestTree+deleteTests =+  let t = fromList [6, 2, 7, 1, 5] -- 1-2, 5-7+  in testGroup "delete should" [+    testCase "remove an element" $ notMember 2 (delete 2 t) @?= True,+    testCase "not affect membership for other items" $ member 1 (delete 2 t) @?= True,+    testCase "produce valid trees" $ all valid (scanr delete t (sort (elems t))) @?= True+  ]++fromListTests :: TestTree+fromListTests = testGroup "fromList" [+    testProperty "should compose with elems to form (sort . nub)" $ nubSortProperty @Int,+    testProperty "specifically, case 1" $ nubSortProperty [2,0,3,4,2,6],+    testProperty "specifically, case 2" $ nubSortProperty [6,7,4,0,6,10,2,12,8]+  ]++findMinMinimum :: (Ord a, Show a, Enum a) => RangeSet a -> Property+findMinMinimum t = findMin t === safeMinimum (elems t)+  where+    safeMinimum [] = Nothing+    safeMinimum xs = Just $ minimum xs++findMaxMaximum :: (Ord a, Show a, Enum a) => RangeSet a -> Property+findMaxMaximum t = findMax t === safeMaximum (elems t)+  where+    safeMaximum [] = Nothing+    safeMaximum xs = Just $ maximum xs++nubSortProperty :: (Enum a, Ord a, Show a) => [a] -> Property+nubSortProperty xs = sort (nub xs) === elems (fromList xs)++memberElemProperty :: (Enum a, Ord a, Show a) => a -> RangeSet a -> Property+memberElemProperty x t = member x t === elem x (elems t)++elemUnelemDisjoint :: (Enum a, Bounded a, Eq a, Show a) => RangeSet a -> Property+elemUnelemDisjoint t = intersect (elems t) (unelems t) === []++complementInverse :: (Enum a, Bounded a, Ord a, Show a) => RangeSet a -> Property+complementInverse t = elems (complement (complement t)) === elems t++complementElemsInverse :: (Enum a, Bounded a, Ord a, Show a) => RangeSet a -> Property+complementElemsInverse t = unelems t === elems (complement t)++unionProperty :: (Ord a, Enum a, Show a) => RangeSet a -> RangeSet a -> Property+unionProperty t1 t2 = not (null t1 && null t2) ==>+  forAll (elements (elems t1 ++ elems t2)) (\x ->+         member x (t1 `union` t2))+  .&&. valid (t1 `union` t2)++intersectionProperty :: (Ord a, Enum a, Show a) => RangeSet a -> RangeSet a -> Property+intersectionProperty t1 t2 = not (null t1 && null t2) ==>+  forAll (elements (elems t1 ++ elems t2)) (\x ->+         (member x t1 && member x t2) === member x (t1 `intersection` t2))+  .&&. valid (t1 `intersection` t2)++differenceProperty :: (Ord a, Enum a, Show a) => RangeSet a -> RangeSet a -> Property+differenceProperty t1 t2 = not (null t1 && null t2) ==>+  forAll (elements (elems t1 ++ elems t2)) (\x ->+         (member x t1 && not (member x t2)) === member x (t1 `difference` t2))+  .&&. valid (t1 `difference` t2)++allLessMin :: (Ord a, Enum a, Show a) => RangeSet a -> a -> Property+allLessMin t x = allLess x t === fromList (filter (< x) (elems t))++allMoreMax :: (Ord a, Enum a, Show a) => RangeSet a -> a -> Property+allMoreMax t x = allMore x t === fromList (filter (> x) (elems t))++{-+    fromRanges, insertRange+-}

@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell, UnboxedTuples, ScopedTypeVariables, TypeApplications #-}+-- {-# OPTIONS_GHC -ddump-splices #-} module Main where import Test.Tasty import Test.Tasty.HUnit@@ -132,6 +133,12 @@ posAfterTab :: String -> Maybe ((Int, Int), (Int, Int)) posAfterTab = $$(parseMocked Parsers.posAfterTab  [||Parsers.posAfterTab||]) +posAfterLookahead :: String -> Maybe ((Int, Int), (Int, Int))+posAfterLookahead = $$(parseMocked Parsers.posAfterLookahead [||Parsers.posAfterLookahead||])++posAfterNotFollowedBy :: String -> Maybe ((Int, Int), (Int, Int))+posAfterNotFollowedBy = $$(parseMocked Parsers.posAfterNotFollowedBy [||Parsers.posAfterNotFollowedBy||])+ positionTests :: TestTree positionTests = testGroup "position combinators should"   [ testCase "start at line 1" $ lineStarts1 "" @?= Just 1@@ -139,4 +146,6 @@   , testCase "advance by 1 column only after regular character" $ posAfterA "a" @?= Just (1, 2)   , testCase "advance by 1 line and reset column after newline" $ posAfterNewline "a\n\n" @?= Just ((2, 1), (3, 1))   , testCase "advance to nearest tab boundary on tab" $ posAfterTab "\ta\t" @?= Just ((1, 5), (1, 9))+  , testCase "work with lookahead" $ posAfterLookahead "\t" @?= Just ((1, 1), (1, 5))+  , testCase "work with notFollowedBy" $ posAfterNotFollowedBy "\n" @?= Just ((1, 1), (2, 1))   ]

@@ -3,13 +3,14 @@  import Prelude hiding (pure, (<*>), (*>), (<*)) import Data.Char (isDigit)-import Parsley.Internal (Parser, Defunc(EMPTY, LIFTED, EQ_H, CONS, LAM_S), makeQ, pure, satisfy, (*>), (<*), (<|>), (<*>), satisfy, lookAhead, line, col)+import Parsley.Internal (Parser, Defunc(EMPTY, LIFTED, RANGES, CONS), makeQ, pure, satisfy, (*>), (<*), (<|>), (<*>), satisfy, lookAhead, notFollowedBy, line, col)+import Text.ParserCombinators.ReadP (look)  char :: Char -> Parser Char-char c = satisfy (EQ_H (LIFTED c))+char c = satisfy (RANGES True [(c, c)])  item :: Parser Char-item = satisfy (LAM_S (const (LIFTED True)))+item = satisfy (RANGES False [])  pure7 :: Parser Int pure7 = pure (LIFTED 7)@@ -48,3 +49,9 @@  posAfterTab :: Parser ((Int, Int), (Int, Int)) posAfterTab = (char '\t' *> pos) <~> (char 'a' *> char '\t' *> pos)++posAfterLookahead :: Parser ((Int, Int), (Int, Int))+posAfterLookahead = lookAhead (char '\t') *> pos <~> (item *> pos)++posAfterNotFollowedBy :: Parser ((Int, Int), (Int, Int))+posAfterNotFollowedBy = notFollowedBy (char '\t') *> pos <~> (item *> pos)