From ba67998e2163446a9492d8328ea55f96c1f62288 Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Fri, 26 Jan 2024 12:06:34 +0000 Subject: [PATCH 01/25] feat(Internal): Added Defunc skeleton --- benchmarks/Main.hs | 4 +- gigaparsec.cabal | 1 + src/Text/Gigaparsec/Internal/Errors.hs | 8 ++- .../Gigaparsec/Internal/Errors/DefuncError.hs | 68 +++++++++++++++++++ 4 files changed, 75 insertions(+), 6 deletions(-) create mode 100644 src/Text/Gigaparsec/Internal/Errors/DefuncError.hs diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs index 3724386f..aabbf358 100644 --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -4,15 +4,13 @@ module Main (main) where import Gauge (defaultMain, bench, nf) -import Text.Gigaparsec (Parsec, Result(Success, Failure), parse, atomic, (<|>)) +import Text.Gigaparsec (Parsec, Result, parse, atomic, (<|>)) import Text.Gigaparsec.Char (string) import Control.DeepSeq (NFData) -import GHC.Generics (Generic) p :: Parsec String p = atomic (string "hello wold") <|> atomic (string "hi") <|> string "hello world" -deriving stock instance Generic (Result e a) deriving anyclass instance (NFData a, NFData e) => NFData (Result e a) main :: IO () diff --git a/gigaparsec.cabal b/gigaparsec.cabal index 88627f93..78da4e10 100644 --- a/gigaparsec.cabal +++ b/gigaparsec.cabal @@ -102,6 +102,7 @@ library -- Internals Text.Gigaparsec.Internal, Text.Gigaparsec.Internal.Errors, + Text.Gigaparsec.Internal.Errors.DefuncError, Text.Gigaparsec.Internal.RT, Text.Gigaparsec.Internal.Require, Text.Gigaparsec.Internal.Token.Generic, diff --git a/src/Text/Gigaparsec/Internal/Errors.hs b/src/Text/Gigaparsec/Internal/Errors.hs index e758f01d..a4bae3da 100644 --- a/src/Text/Gigaparsec/Internal/Errors.hs +++ b/src/Text/Gigaparsec/Internal/Errors.hs @@ -1,8 +1,10 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE RecordWildCards, BangPatterns, NamedFieldPuns, CPP #-} -#include "portable-unlifted.h" {-# OPTIONS_GHC -Wno-partial-fields -Wno-all-missed-specialisations -Wno-missing-import-lists #-} {-# OPTIONS_HADDOCK hide #-} +#include "portable-unlifted.h" +-- Yes, this is redundant, however, it is necessary to get the UNPACK to fire on CaretWidth +{-# OPTIONS_GHC -Wno-redundant-strictness-flags #-} module Text.Gigaparsec.Internal.Errors (module Text.Gigaparsec.Internal.Errors) where import Prelude hiding (lines) @@ -47,7 +49,7 @@ data ParseError = VanillaError { presentationOffset :: {-# UNPACK #-} !Word , col :: {-# UNPACK #-} !Word , msgs :: ![String] --, caretWidth :: {-# UNPACK #-} !Span --FIXME: need defunc before this goes away - , caretWidth :: CaretWidth + , caretWidth :: {-# UNPACK #-} !CaretWidth -- TODO: remove: , underlyingOffset :: {-# UNPACK #-} !Word , entrenchment :: {-# UNPACK #-} !Word @@ -57,7 +59,7 @@ type Input :: * type Input = NonEmpty Char type UnexpectItem :: * data UnexpectItem = UnexpectRaw !Input {-# UNPACK #-} !Word - | UnexpectNamed !String CaretWidth + | UnexpectNamed !String {-# UNPACK #-} !CaretWidth | UnexpectEndOfInput type ExpectItem :: * data ExpectItem = ExpectRaw !String diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs new file mode 100644 index 00000000..9d87750e --- /dev/null +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns, CPP, DataKinds, GADTs, UnboxedSums #-} +{-# OPTIONS_GHC -Wno-partial-fields -Wno-all-missed-specialisations -Wno-missing-import-lists #-} +{-# OPTIONS_HADDOCK hide #-} +-- Yes, this is redundant, however, it is necessary to get the UNPACK to fire +{-# OPTIONS_GHC -Wno-redundant-strictness-flags #-} +#include "portable-unlifted.h" +module Text.Gigaparsec.Internal.Errors.DefuncError ( + module Text.Gigaparsec.Internal.Errors.DefuncError + ) where + +import Data.Word (Word32) +import Data.Set (Set) + +CPP_import_PortableUnlifted + +-- TODO: remove +type Span :: * +type Span = Word + +type ErrKind :: * +data ErrKind = Vanilla | Specialised + +type DefuncError :: ErrKind -> UnliftedDatatype +data DefuncError k = DefuncError { + flags :: {-# UNPACK #-} !Word32, + presentationOffset :: {-# UNPACK #-} !Word, + errTy :: {-# UNPACK #-} !(DefuncError_ k) + } + +type DefuncError_ :: ErrKind -> UnliftedDatatype +data DefuncError_ k where + Base :: { line :: {-# UNPACK #-} !Word + , col :: {-# UNPACK #-} !Word + , base :: {-# UNPACK #-} !(BaseError k) + } + -> DefuncError_ k + Op :: { underlyingOffset :: {-# UNPACK #-} !Word + , op :: {-# UNPACK #-} !(ErrorOp k) + } -> DefuncError_ k + + +type BaseError :: ErrKind -> UnliftedDatatype +data BaseError k where + ClassicSpecialised :: ![String] -> BaseError 'Specialised + Expected :: {-!(Set ExpectItem) ->-} {-# UNPACK #-} !Span -> BaseError 'Vanilla + ExpectedWithReason :: {-!(Set ExpectItem) ->-} !String -> {-# UNPACK #-} !Span -> BaseError 'Vanilla + Unexpected :: {-!(Set ExpectItem) -> !String -> {-# UNPACK #-} !CaretWidth -> -} BaseError 'Vanilla + Empty :: {-# UNPACK #-} !Span -> BaseError 'Vanilla + EmptyWithReason :: !String -> {-# UNPACK #-} !Span -> BaseError 'Vanilla + +type ErrorOp :: ErrKind -> UnliftedDatatype +data ErrorOp k where + Merged :: !(DefuncError k) -> !(DefuncError k) -> ErrorOp k + AdjustCaret :: !(DefuncError 'Specialised) + -> !(DefuncError 'Vanilla) -- ^ caretAdjuster + -> ErrorOp 'Specialised + WithHints :: !(DefuncError 'Vanilla) {- -> !DefuncHints -}-> ErrorOp 'Vanilla + WithReason :: !(DefuncError 'Vanilla) -> !String -> ErrorOp 'Vanilla + WithLabel :: !(DefuncError 'Vanilla) -> !(Set String) -> ErrorOp 'Vanilla + Amended :: {-# UNPACK #-} !Word -- ^ line + -> {-# UNPACK #-} !Word -- ^ col + -> !(DefuncError k) -> ErrorOp k + Entrenched :: {-# UNPACK #-} !Word -- ^ by + -> !(DefuncError k) -> ErrorOp k + Dislodged :: {-# UNPACK #-} !Word -- ^ by + -> !(DefuncError k) -> ErrorOp k + Lexical :: !(DefuncError 'Vanilla) -> ErrorOp 'Vanilla From 3431d7000583838dd0927c40b3d54f152429726d Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Fri, 26 Jan 2024 12:39:45 +0000 Subject: [PATCH 02/25] refactor(Internal): moved some stuff into new modules --- gigaparsec.cabal | 4 ++- src/Text/Gigaparsec/Internal/Errors.hs | 31 +++++-------------- .../Internal/Errors/CaretControl.hs | 20 ++++++++++++ .../Errors/{DefuncError.hs => DefuncTypes.hs} | 28 ++++++++++------- .../Gigaparsec/Internal/Errors/ErrorItem.hs | 22 +++++++++++++ 5 files changed, 69 insertions(+), 36 deletions(-) create mode 100644 src/Text/Gigaparsec/Internal/Errors/CaretControl.hs rename src/Text/Gigaparsec/Internal/Errors/{DefuncError.hs => DefuncTypes.hs} (70%) create mode 100644 src/Text/Gigaparsec/Internal/Errors/ErrorItem.hs diff --git a/gigaparsec.cabal b/gigaparsec.cabal index 78da4e10..01172125 100644 --- a/gigaparsec.cabal +++ b/gigaparsec.cabal @@ -102,7 +102,9 @@ library -- Internals Text.Gigaparsec.Internal, Text.Gigaparsec.Internal.Errors, - Text.Gigaparsec.Internal.Errors.DefuncError, + Text.Gigaparsec.Internal.Errors.CaretControl, + Text.Gigaparsec.Internal.Errors.DefuncTypes, + Text.Gigaparsec.Internal.Errors.ErrorItem, Text.Gigaparsec.Internal.RT, Text.Gigaparsec.Internal.Require, Text.Gigaparsec.Internal.Token.Generic, diff --git a/src/Text/Gigaparsec/Internal/Errors.hs b/src/Text/Gigaparsec/Internal/Errors.hs index a4bae3da..079b2555 100644 --- a/src/Text/Gigaparsec/Internal/Errors.hs +++ b/src/Text/Gigaparsec/Internal/Errors.hs @@ -5,7 +5,10 @@ #include "portable-unlifted.h" -- Yes, this is redundant, however, it is necessary to get the UNPACK to fire on CaretWidth {-# OPTIONS_GHC -Wno-redundant-strictness-flags #-} -module Text.Gigaparsec.Internal.Errors (module Text.Gigaparsec.Internal.Errors) where +module Text.Gigaparsec.Internal.Errors ( + module Text.Gigaparsec.Internal.Errors, + CaretWidth(..), ExpectItem(..) + ) where import Prelude hiding (lines) @@ -17,18 +20,10 @@ import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder, Token) import Text.Gigaparsec.Errors.ErrorBuilder qualified as Builder (ErrorBuilder(..)) import Text.Gigaparsec.Errors.ErrorBuilder qualified as Token (Token(..)) -CPP_import_PortableUnlifted - -type Span :: * -type Span = Word - -type CaretWidth :: UnliftedDatatype -data CaretWidth = FlexibleCaret { width :: {-# UNPACK #-} !Span } - | RigidCaret { width :: {-# UNPACK #-} !Span } +import Text.Gigaparsec.Internal.Errors.CaretControl +import Text.Gigaparsec.Internal.Errors.ErrorItem -isFlexible :: CaretWidth -> Bool -isFlexible FlexibleCaret{} = True -isFlexible _ = False +CPP_import_PortableUnlifted type ParseError :: UnliftedDatatype data ParseError = VanillaError { presentationOffset :: {-# UNPACK #-} !Word @@ -55,18 +50,6 @@ data ParseError = VanillaError { presentationOffset :: {-# UNPACK #-} !Word , entrenchment :: {-# UNPACK #-} !Word } -type Input :: * -type Input = NonEmpty Char -type UnexpectItem :: * -data UnexpectItem = UnexpectRaw !Input {-# UNPACK #-} !Word - | UnexpectNamed !String {-# UNPACK #-} !CaretWidth - | UnexpectEndOfInput -type ExpectItem :: * -data ExpectItem = ExpectRaw !String - | ExpectNamed !String - | ExpectEndOfInput - deriving stock (Eq, Ord, Show) - entrenched :: ParseError -> Bool entrenched err = entrenchment err /= 0 diff --git a/src/Text/Gigaparsec/Internal/Errors/CaretControl.hs b/src/Text/Gigaparsec/Internal/Errors/CaretControl.hs new file mode 100644 index 00000000..3f054ae5 --- /dev/null +++ b/src/Text/Gigaparsec/Internal/Errors/CaretControl.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} +#include "portable-unlifted.h" +module Text.Gigaparsec.Internal.Errors.CaretControl ( + module Text.Gigaparsec.Internal.Errors.CaretControl + ) where + +CPP_import_PortableUnlifted + +type Span :: * +type Span = Word + +type CaretWidth :: UnliftedDatatype +data CaretWidth = FlexibleCaret { width :: {-# UNPACK #-} !Span } + | RigidCaret { width :: {-# UNPACK #-} !Span } + +{-# INLINE isFlexible #-} +isFlexible :: CaretWidth -> Bool +isFlexible FlexibleCaret{} = True +isFlexible _ = False diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs similarity index 70% rename from src/Text/Gigaparsec/Internal/Errors/DefuncError.hs rename to src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs index 9d87750e..f31d6ccc 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs @@ -1,23 +1,22 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE BangPatterns, CPP, DataKinds, GADTs, UnboxedSums #-} +{-# LANGUAGE BangPatterns, CPP, DataKinds, GADTs #-} {-# OPTIONS_GHC -Wno-partial-fields -Wno-all-missed-specialisations -Wno-missing-import-lists #-} {-# OPTIONS_HADDOCK hide #-} -- Yes, this is redundant, however, it is necessary to get the UNPACK to fire {-# OPTIONS_GHC -Wno-redundant-strictness-flags #-} #include "portable-unlifted.h" -module Text.Gigaparsec.Internal.Errors.DefuncError ( - module Text.Gigaparsec.Internal.Errors.DefuncError +module Text.Gigaparsec.Internal.Errors.DefuncTypes ( + module Text.Gigaparsec.Internal.Errors.DefuncTypes ) where +import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth, Span) +import Text.Gigaparsec.Internal.Errors.ErrorItem (ExpectItem) + import Data.Word (Word32) import Data.Set (Set) CPP_import_PortableUnlifted --- TODO: remove -type Span :: * -type Span = Word - type ErrKind :: * data ErrKind = Vanilla | Specialised @@ -43,9 +42,9 @@ data DefuncError_ k where type BaseError :: ErrKind -> UnliftedDatatype data BaseError k where ClassicSpecialised :: ![String] -> BaseError 'Specialised - Expected :: {-!(Set ExpectItem) ->-} {-# UNPACK #-} !Span -> BaseError 'Vanilla - ExpectedWithReason :: {-!(Set ExpectItem) ->-} !String -> {-# UNPACK #-} !Span -> BaseError 'Vanilla - Unexpected :: {-!(Set ExpectItem) -> !String -> {-# UNPACK #-} !CaretWidth -> -} BaseError 'Vanilla + Expected :: !(Set ExpectItem) -> {-# UNPACK #-} !Span -> BaseError 'Vanilla + ExpectedWithReason :: !(Set ExpectItem) -> !String -> {-# UNPACK #-} !Span -> BaseError 'Vanilla + Unexpected :: !(Set ExpectItem) -> !String -> {-# UNPACK #-} !CaretWidth -> BaseError 'Vanilla Empty :: {-# UNPACK #-} !Span -> BaseError 'Vanilla EmptyWithReason :: !String -> {-# UNPACK #-} !Span -> BaseError 'Vanilla @@ -55,7 +54,7 @@ data ErrorOp k where AdjustCaret :: !(DefuncError 'Specialised) -> !(DefuncError 'Vanilla) -- ^ caretAdjuster -> ErrorOp 'Specialised - WithHints :: !(DefuncError 'Vanilla) {- -> !DefuncHints -}-> ErrorOp 'Vanilla + WithHints :: !(DefuncError 'Vanilla) -> !DefuncHints -> ErrorOp 'Vanilla WithReason :: !(DefuncError 'Vanilla) -> !String -> ErrorOp 'Vanilla WithLabel :: !(DefuncError 'Vanilla) -> !(Set String) -> ErrorOp 'Vanilla Amended :: {-# UNPACK #-} !Word -- ^ line @@ -66,3 +65,10 @@ data ErrorOp k where Dislodged :: {-# UNPACK #-} !Word -- ^ by -> !(DefuncError k) -> ErrorOp k Lexical :: !(DefuncError 'Vanilla) -> ErrorOp 'Vanilla + +type DefuncHints :: UnliftedDatatype +data DefuncHints where + Blank :: DefuncHints + Replace :: !(Set String) -> DefuncHints + Merge :: !DefuncHints -> !DefuncHints -> DefuncHints + AddErr :: !DefuncHints -> !(DefuncError 'Vanilla) -> DefuncHints diff --git a/src/Text/Gigaparsec/Internal/Errors/ErrorItem.hs b/src/Text/Gigaparsec/Internal/Errors/ErrorItem.hs new file mode 100644 index 00000000..de2997b3 --- /dev/null +++ b/src/Text/Gigaparsec/Internal/Errors/ErrorItem.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Safe #-} +-- Yes, this is redundant, however, it is necessary to get the UNPACK to fire on CaretWidth +{-# OPTIONS_GHC -Wno-redundant-strictness-flags #-} +module Text.Gigaparsec.Internal.Errors.ErrorItem ( + module Text.Gigaparsec.Internal.Errors.ErrorItem + ) where + +import Data.List.NonEmpty (NonEmpty) + +import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth) + +type Input :: * +type Input = NonEmpty Char +type UnexpectItem :: * +data UnexpectItem = UnexpectRaw !Input {-# UNPACK #-} !Word + | UnexpectNamed !String {-# UNPACK #-} !CaretWidth + | UnexpectEndOfInput +type ExpectItem :: * +data ExpectItem = ExpectRaw !String + | ExpectNamed !String + | ExpectEndOfInput + deriving stock (Eq, Ord, Show) From 96b96affe4a087088b5bb01300e02c416863282f Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Fri, 26 Jan 2024 15:28:19 +0000 Subject: [PATCH 03/25] feat(Internal): implemented all DefuncError ops --- gigaparsec.cabal | 1 + .../Gigaparsec/Internal/Errors/DefuncError.hs | 138 ++++++++++++++++++ .../Gigaparsec/Internal/Errors/DefuncTypes.hs | 44 +++--- 3 files changed, 166 insertions(+), 17 deletions(-) create mode 100644 src/Text/Gigaparsec/Internal/Errors/DefuncError.hs diff --git a/gigaparsec.cabal b/gigaparsec.cabal index 01172125..cc1c7b5c 100644 --- a/gigaparsec.cabal +++ b/gigaparsec.cabal @@ -103,6 +103,7 @@ library Text.Gigaparsec.Internal, Text.Gigaparsec.Internal.Errors, Text.Gigaparsec.Internal.Errors.CaretControl, + Text.Gigaparsec.Internal.Errors.DefuncError, Text.Gigaparsec.Internal.Errors.DefuncTypes, Text.Gigaparsec.Internal.Errors.ErrorItem, Text.Gigaparsec.Internal.RT, diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs new file mode 100644 index 00000000..a4f58d47 --- /dev/null +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE NamedFieldPuns, BinaryLiterals, NumericUnderscores, DataKinds, MonoLocalBinds, BangPatterns #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} +module Text.Gigaparsec.Internal.Errors.DefuncError ( + DefuncError, + merge, withHints, withReason, withReasonAndOffset, label, + amend, entrench, dislodge, markAsLexical, + isVanilla, isExpectedEmpty, isLexical + ) where + +import Data.Word (Word32) +import Data.Bits ((.&.), testBit, clearBit, setBit, complement) +import Data.Set (Set) +import Data.Set qualified as Set (null) + +import Text.Gigaparsec.Internal.Errors.DefuncTypes ( + DefuncError(..), DefuncError_(..), ErrKindSingleton(..), ErrorOp(..), ErrKind(..), + DefuncHints(..) + ) + +{-# INLINABLE isVanilla #-} +isVanilla :: DefuncError -> Bool +isVanilla DefuncError{flags} = testBit flags vanillaBit + +{-# INLINABLE isExpectedEmpty #-} +isExpectedEmpty :: DefuncError -> Bool +isExpectedEmpty DefuncError{flags} = testBit flags expectedEmptyBit + +{-# INLINABLE entrenchedBy #-} +entrenchedBy :: DefuncError -> Word32 +entrenchedBy DefuncError{flags} = flags .&. entrenchedMask + +{-# INLINABLE entrenched #-} +entrenched :: DefuncError -> Bool +entrenched err = entrenchedBy err > 0 + +{-# INLINABLE isFlexibleCaret #-} +isFlexibleCaret :: DefuncError -> Bool +isFlexibleCaret DefuncError{flags} = testBit flags flexibleCaretBit + +{-# INLINABLE isLexical #-} +isLexical :: DefuncError -> Bool +isLexical DefuncError{flags} = testBit flags lexicalBit + +--TODO: make one for Word + DefuncError_ +underlyingOffset :: DefuncError -> Word +underlyingOffset (DefuncError _ _ presentationOffset Base{}) = presentationOffset +underlyingOffset (DefuncError _ _ _ Op{_underlyingOffset}) = _underlyingOffset + +merge :: DefuncError -> DefuncError -> DefuncError +merge err1 err2 = case compare (underlyingOffset err1) (underlyingOffset err2) of + GT -> err1 + LT -> err2 + EQ -> case compare (presentationOffset err1) (presentationOffset err2) of + GT -> err1 + LT -> err2 + EQ -> case err1 of + DefuncError IsSpecialised _ _ errTy1 + | DefuncError IsSpecialised _ _ errTy2 <- err2 -> + mergeSame err1 (flags err2) IsSpecialised errTy1 errTy2 + | DefuncError IsVanilla _ _ errTy2 <- err2 + , isFlexibleCaret err1 -> adjustCaret err1 errTy1 errTy2 + | otherwise -> err1 + DefuncError IsVanilla _ _ errTy1 + | DefuncError IsVanilla _ _ errTy2 <- err2 -> + mergeSame err1 (flags err2) IsVanilla errTy1 errTy2 + | DefuncError IsSpecialised _ _ errTy2 <- err2 + , isFlexibleCaret err2 -> adjustCaret err1 errTy2 errTy1 + | otherwise -> err2 + +withHints :: DefuncHints -> DefuncError -> DefuncError +withHints Blank err = err +withHints hints err@(DefuncError IsVanilla flags pOff errTy) = + DefuncError IsVanilla (clearBit flags expectedEmptyBit) pOff + (Op (underlyingOffset err) (WithHints errTy hints)) +withHints _ err = err + +withReasonAndOffset :: String -> Word -> DefuncError -> DefuncError +withReasonAndOffset !reason !off err@(DefuncError IsVanilla flags pOff errTy) | pOff == off = + DefuncError IsVanilla flags pOff (Op (underlyingOffset err) (WithReason errTy reason)) +withReasonAndOffset _ _ err = err + +withReason :: String -> DefuncError -> DefuncError +withReason !reason err = withReasonAndOffset reason (presentationOffset err) err + +label :: Set String -> Word -> DefuncError -> DefuncError +label !labels !off err@(DefuncError IsVanilla flags pOff errTy) | pOff == off = + DefuncError IsVanilla flags' pOff (Op (underlyingOffset err) (WithLabel errTy labels)) + where !flags' + | Set.null labels = setBit flags expectedEmptyBit + | otherwise = clearBit flags expectedEmptyBit +label _ _ err = err + +amend :: Bool -> Word -> Word -> Word -> DefuncError -> DefuncError +amend !partial !pOff !line !col err@(DefuncError k flags _ errTy) + | entrenched err = err + | otherwise = DefuncError k flags pOff (Op uOff (Amended k line col errTy)) + where + !uOff = if partial then underlyingOffset err else pOff + +entrench :: DefuncError -> DefuncError +entrench (DefuncError k flags pOff errTy) = DefuncError k (flags + 1) pOff errTy + +dislodge :: Word32 -> DefuncError -> DefuncError +dislodge by err@(DefuncError k flags pOff errTy) + | eBy == 0 = err + | eBy > by = DefuncError k (flags - by) pOff errTy + | otherwise = DefuncError k (flags .&. complement entrenchedMask) pOff errTy + where !eBy = entrenchedBy err + +markAsLexical :: Word -> DefuncError -> DefuncError +markAsLexical !off err@(DefuncError IsVanilla flags pOff errTy) | off == pOff = + DefuncError IsVanilla (setBit flags lexicalBit) pOff (Op (underlyingOffset err) (Lexical errTy)) +markAsLexical _ err = err + +{-# INLINABLE adjustCaret #-} +adjustCaret :: DefuncError -> DefuncError_ 'Specialised -> DefuncError_ 'Vanilla -> DefuncError +adjustCaret err@(DefuncError _ flags pOff _) err1 err2 = + DefuncError IsSpecialised flags pOff (Op (underlyingOffset err) (AdjustCaret err1 err2)) + +{-# INLINABLE mergeSame #-} +mergeSame :: DefuncError -> Word32 -> ErrKindSingleton k -> DefuncError_ k -> DefuncError_ k -> DefuncError +mergeSame err@(DefuncError _ flags1 uOff _) !flags2 k err1 err2 = + DefuncError k (flags1 .&. flags2) uOff (Op (underlyingOffset err) (Merged k err1 err2)) + +-- FLAG MASKS +{-# INLINE vanillaBit #-} +{-# INLINE expectedEmptyBit #-} +{-# INLINE lexicalBit #-} +{-# INLINE flexibleCaretBit #-} +{-# INLINE entrenchedMask #-} +vanillaBit, expectedEmptyBit, lexicalBit, flexibleCaretBit :: Int +vanillaBit = 31 +expectedEmptyBit = 30 +lexicalBit = 29 +flexibleCaretBit = 28 +entrenchedMask :: Word32 +entrenchedMask = 0b00001111_11111111_11111111_11111111 diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs index f31d6ccc..153fe304 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs @@ -20,8 +20,14 @@ CPP_import_PortableUnlifted type ErrKind :: * data ErrKind = Vanilla | Specialised -type DefuncError :: ErrKind -> UnliftedDatatype -data DefuncError k = DefuncError { +type ErrKindSingleton :: ErrKind -> UnliftedDatatype +data ErrKindSingleton k where + IsVanilla :: ErrKindSingleton 'Vanilla + IsSpecialised :: ErrKindSingleton 'Specialised + +type DefuncError :: UnliftedDatatype +data DefuncError = forall k. DefuncError { + errKind :: {-# UNPACK #-} !(ErrKindSingleton k), flags :: {-# UNPACK #-} !Word32, presentationOffset :: {-# UNPACK #-} !Word, errTy :: {-# UNPACK #-} !(DefuncError_ k) @@ -34,7 +40,7 @@ data DefuncError_ k where , base :: {-# UNPACK #-} !(BaseError k) } -> DefuncError_ k - Op :: { underlyingOffset :: {-# UNPACK #-} !Word + Op :: { _underlyingOffset :: {-# UNPACK #-} !Word , op :: {-# UNPACK #-} !(ErrorOp k) } -> DefuncError_ k @@ -50,25 +56,29 @@ data BaseError k where type ErrorOp :: ErrKind -> UnliftedDatatype data ErrorOp k where - Merged :: !(DefuncError k) -> !(DefuncError k) -> ErrorOp k - AdjustCaret :: !(DefuncError 'Specialised) - -> !(DefuncError 'Vanilla) -- ^ caretAdjuster + Merged :: {-# UNPACK #-} !(ErrKindSingleton k) + -> {-# UNPACK #-} !(DefuncError_ k) -> {-# UNPACK #-} !(DefuncError_ k) -> ErrorOp k + AdjustCaret :: {-# UNPACK #-} !(DefuncError_ 'Specialised) + -> {-# UNPACK #-} !(DefuncError_ 'Vanilla) -- ^ caretAdjuster -> ErrorOp 'Specialised - WithHints :: !(DefuncError 'Vanilla) -> !DefuncHints -> ErrorOp 'Vanilla - WithReason :: !(DefuncError 'Vanilla) -> !String -> ErrorOp 'Vanilla - WithLabel :: !(DefuncError 'Vanilla) -> !(Set String) -> ErrorOp 'Vanilla - Amended :: {-# UNPACK #-} !Word -- ^ line + WithHints :: {-# UNPACK #-} !(DefuncError_ 'Vanilla) -> !DefuncHints -> ErrorOp 'Vanilla + WithReason :: {-# UNPACK #-} !(DefuncError_ 'Vanilla) -> !String -> ErrorOp 'Vanilla + WithLabel :: {-# UNPACK #-} !(DefuncError_ 'Vanilla) -> !(Set String) -> ErrorOp 'Vanilla + Amended :: {-# UNPACK #-} !(ErrKindSingleton k) + -> {-# UNPACK #-} !Word -- ^ line -> {-# UNPACK #-} !Word -- ^ col - -> !(DefuncError k) -> ErrorOp k - Entrenched :: {-# UNPACK #-} !Word -- ^ by - -> !(DefuncError k) -> ErrorOp k - Dislodged :: {-# UNPACK #-} !Word -- ^ by - -> !(DefuncError k) -> ErrorOp k - Lexical :: !(DefuncError 'Vanilla) -> ErrorOp 'Vanilla + -> {-# UNPACK #-} !(DefuncError_ k) -> ErrorOp k + {-Entrenched :: {-# UNPACK #-} !(ErrKindSingleton k) + -> {-# UNPACK #-} !Word32 -- ^ by + -> {-# UNPACK #-} !(DefuncError_ k) -> ErrorOp k + Dislodged :: {-# UNPACK #-} !(ErrKindSingleton k) + -> {-# UNPACK #-} !Word32 -- ^ by + -> {-# UNPACK #-} !(DefuncError_ k) -> ErrorOp k-} + Lexical :: {-# UNPACK #-} !(DefuncError_ 'Vanilla) -> ErrorOp 'Vanilla type DefuncHints :: UnliftedDatatype data DefuncHints where Blank :: DefuncHints Replace :: !(Set String) -> DefuncHints Merge :: !DefuncHints -> !DefuncHints -> DefuncHints - AddErr :: !DefuncHints -> !(DefuncError 'Vanilla) -> DefuncHints + AddErr :: !DefuncHints -> {-# UNPACK #-} !(DefuncError_ 'Vanilla) -> DefuncHints From 2ad0c3b279f6b23321cae0a7f03025e64492fde1 Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Fri, 26 Jan 2024 15:31:08 +0000 Subject: [PATCH 04/25] fix(Internal): added GADTs --- src/Text/Gigaparsec/Internal/Errors/DefuncError.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs index a4f58d47..037d8236 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Safe #-} -{-# LANGUAGE NamedFieldPuns, BinaryLiterals, NumericUnderscores, DataKinds, MonoLocalBinds, BangPatterns #-} +{-# LANGUAGE GADTs, NamedFieldPuns, BinaryLiterals, NumericUnderscores, DataKinds, BangPatterns #-} {-# OPTIONS_GHC -Wno-missing-import-lists #-} module Text.Gigaparsec.Internal.Errors.DefuncError ( DefuncError, From e2a6d3b9bf25f9b892fa14a0b58cb9bb93fa7a3f Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Fri, 26 Jan 2024 15:52:15 +0000 Subject: [PATCH 05/25] refactor(Internal): move underlyingOffset out --- .../Gigaparsec/Internal/Errors/DefuncError.hs | 56 +++++++++---------- .../Gigaparsec/Internal/Errors/DefuncTypes.hs | 5 +- 2 files changed, 27 insertions(+), 34 deletions(-) diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs index 037d8236..c36dd1dd 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs @@ -42,11 +42,6 @@ isFlexibleCaret DefuncError{flags} = testBit flags flexibleCaretBit isLexical :: DefuncError -> Bool isLexical DefuncError{flags} = testBit flags lexicalBit ---TODO: make one for Word + DefuncError_ -underlyingOffset :: DefuncError -> Word -underlyingOffset (DefuncError _ _ presentationOffset Base{}) = presentationOffset -underlyingOffset (DefuncError _ _ _ Op{_underlyingOffset}) = _underlyingOffset - merge :: DefuncError -> DefuncError -> DefuncError merge err1 err2 = case compare (underlyingOffset err1) (underlyingOffset err2) of GT -> err1 @@ -55,73 +50,72 @@ merge err1 err2 = case compare (underlyingOffset err1) (underlyingOffset err2) o GT -> err1 LT -> err2 EQ -> case err1 of - DefuncError IsSpecialised _ _ errTy1 - | DefuncError IsSpecialised _ _ errTy2 <- err2 -> + DefuncError IsSpecialised _ _ _ errTy1 + | DefuncError IsSpecialised _ _ _ errTy2 <- err2 -> mergeSame err1 (flags err2) IsSpecialised errTy1 errTy2 - | DefuncError IsVanilla _ _ errTy2 <- err2 + | DefuncError IsVanilla _ _ _ errTy2 <- err2 , isFlexibleCaret err1 -> adjustCaret err1 errTy1 errTy2 | otherwise -> err1 - DefuncError IsVanilla _ _ errTy1 - | DefuncError IsVanilla _ _ errTy2 <- err2 -> + DefuncError IsVanilla _ _ _ errTy1 + | DefuncError IsVanilla _ _ _ errTy2 <- err2 -> mergeSame err1 (flags err2) IsVanilla errTy1 errTy2 - | DefuncError IsSpecialised _ _ errTy2 <- err2 + | DefuncError IsSpecialised _ _ _ errTy2 <- err2 , isFlexibleCaret err2 -> adjustCaret err1 errTy2 errTy1 | otherwise -> err2 withHints :: DefuncHints -> DefuncError -> DefuncError withHints Blank err = err -withHints hints err@(DefuncError IsVanilla flags pOff errTy) = - DefuncError IsVanilla (clearBit flags expectedEmptyBit) pOff - (Op (underlyingOffset err) (WithHints errTy hints)) +withHints hints (DefuncError IsVanilla flags pOff uOff errTy) = + DefuncError IsVanilla (clearBit flags expectedEmptyBit) pOff uOff (Op (WithHints errTy hints)) withHints _ err = err withReasonAndOffset :: String -> Word -> DefuncError -> DefuncError -withReasonAndOffset !reason !off err@(DefuncError IsVanilla flags pOff errTy) | pOff == off = - DefuncError IsVanilla flags pOff (Op (underlyingOffset err) (WithReason errTy reason)) +withReasonAndOffset !reason !off (DefuncError IsVanilla flags pOff uOff errTy) | pOff == off = + DefuncError IsVanilla flags pOff uOff (Op (WithReason errTy reason)) withReasonAndOffset _ _ err = err withReason :: String -> DefuncError -> DefuncError withReason !reason err = withReasonAndOffset reason (presentationOffset err) err label :: Set String -> Word -> DefuncError -> DefuncError -label !labels !off err@(DefuncError IsVanilla flags pOff errTy) | pOff == off = - DefuncError IsVanilla flags' pOff (Op (underlyingOffset err) (WithLabel errTy labels)) +label !labels !off (DefuncError IsVanilla flags pOff uOff errTy) | pOff == off = + DefuncError IsVanilla flags' pOff uOff (Op (WithLabel errTy labels)) where !flags' | Set.null labels = setBit flags expectedEmptyBit | otherwise = clearBit flags expectedEmptyBit label _ _ err = err amend :: Bool -> Word -> Word -> Word -> DefuncError -> DefuncError -amend !partial !pOff !line !col err@(DefuncError k flags _ errTy) +amend !partial !pOff !line !col err@(DefuncError k flags _ uOff errTy) | entrenched err = err - | otherwise = DefuncError k flags pOff (Op uOff (Amended k line col errTy)) + | otherwise = DefuncError k flags pOff uOff' (Op (Amended k line col errTy)) where - !uOff = if partial then underlyingOffset err else pOff + !uOff' = if partial then uOff else pOff entrench :: DefuncError -> DefuncError -entrench (DefuncError k flags pOff errTy) = DefuncError k (flags + 1) pOff errTy +entrench (DefuncError k flags pOff uOff errTy) = DefuncError k (flags + 1) pOff uOff errTy dislodge :: Word32 -> DefuncError -> DefuncError -dislodge by err@(DefuncError k flags pOff errTy) +dislodge by err@(DefuncError k flags pOff uOff errTy) | eBy == 0 = err - | eBy > by = DefuncError k (flags - by) pOff errTy - | otherwise = DefuncError k (flags .&. complement entrenchedMask) pOff errTy + | eBy > by = DefuncError k (flags - by) pOff uOff errTy + | otherwise = DefuncError k (flags .&. complement entrenchedMask) pOff uOff errTy where !eBy = entrenchedBy err markAsLexical :: Word -> DefuncError -> DefuncError -markAsLexical !off err@(DefuncError IsVanilla flags pOff errTy) | off == pOff = - DefuncError IsVanilla (setBit flags lexicalBit) pOff (Op (underlyingOffset err) (Lexical errTy)) +markAsLexical !off (DefuncError IsVanilla flags pOff uOff errTy) | off == pOff = + DefuncError IsVanilla (setBit flags lexicalBit) pOff uOff (Op (Lexical errTy)) markAsLexical _ err = err {-# INLINABLE adjustCaret #-} adjustCaret :: DefuncError -> DefuncError_ 'Specialised -> DefuncError_ 'Vanilla -> DefuncError -adjustCaret err@(DefuncError _ flags pOff _) err1 err2 = - DefuncError IsSpecialised flags pOff (Op (underlyingOffset err) (AdjustCaret err1 err2)) +adjustCaret (DefuncError _ flags pOff uOff _) err1 err2 = + DefuncError IsSpecialised flags pOff uOff (Op (AdjustCaret err1 err2)) {-# INLINABLE mergeSame #-} mergeSame :: DefuncError -> Word32 -> ErrKindSingleton k -> DefuncError_ k -> DefuncError_ k -> DefuncError -mergeSame err@(DefuncError _ flags1 uOff _) !flags2 k err1 err2 = - DefuncError k (flags1 .&. flags2) uOff (Op (underlyingOffset err) (Merged k err1 err2)) +mergeSame (DefuncError _ flags1 pOff uOff _) !flags2 k err1 err2 = + DefuncError k (flags1 .&. flags2) pOff uOff (Op (Merged k err1 err2)) -- FLAG MASKS {-# INLINE vanillaBit #-} diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs index 153fe304..90ce9fb9 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs @@ -30,6 +30,7 @@ data DefuncError = forall k. DefuncError { errKind :: {-# UNPACK #-} !(ErrKindSingleton k), flags :: {-# UNPACK #-} !Word32, presentationOffset :: {-# UNPACK #-} !Word, + underlyingOffset :: {-# UNPACK #-} !Word, errTy :: {-# UNPACK #-} !(DefuncError_ k) } @@ -40,9 +41,7 @@ data DefuncError_ k where , base :: {-# UNPACK #-} !(BaseError k) } -> DefuncError_ k - Op :: { _underlyingOffset :: {-# UNPACK #-} !Word - , op :: {-# UNPACK #-} !(ErrorOp k) - } -> DefuncError_ k + Op :: { op :: {-# UNPACK #-} !(ErrorOp k) } -> DefuncError_ k type BaseError :: ErrKind -> UnliftedDatatype From 5ad560213a2dffe620d51e93de9517b036e576a4 Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Fri, 26 Jan 2024 15:54:00 +0000 Subject: [PATCH 06/25] refactor(Internal): removed superfluous Singleton --- src/Text/Gigaparsec/Internal/Errors/DefuncError.hs | 6 +++--- src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs | 13 ++----------- 2 files changed, 5 insertions(+), 14 deletions(-) diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs index c36dd1dd..b4b67491 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs @@ -88,7 +88,7 @@ label _ _ err = err amend :: Bool -> Word -> Word -> Word -> DefuncError -> DefuncError amend !partial !pOff !line !col err@(DefuncError k flags _ uOff errTy) | entrenched err = err - | otherwise = DefuncError k flags pOff uOff' (Op (Amended k line col errTy)) + | otherwise = DefuncError k flags pOff uOff' (Op (Amended line col errTy)) where !uOff' = if partial then uOff else pOff @@ -104,7 +104,7 @@ dislodge by err@(DefuncError k flags pOff uOff errTy) markAsLexical :: Word -> DefuncError -> DefuncError markAsLexical !off (DefuncError IsVanilla flags pOff uOff errTy) | off == pOff = - DefuncError IsVanilla (setBit flags lexicalBit) pOff uOff (Op (Lexical errTy)) + DefuncError IsVanilla (setBit flags lexicalBit) pOff uOff errTy markAsLexical _ err = err {-# INLINABLE adjustCaret #-} @@ -115,7 +115,7 @@ adjustCaret (DefuncError _ flags pOff uOff _) err1 err2 = {-# INLINABLE mergeSame #-} mergeSame :: DefuncError -> Word32 -> ErrKindSingleton k -> DefuncError_ k -> DefuncError_ k -> DefuncError mergeSame (DefuncError _ flags1 pOff uOff _) !flags2 k err1 err2 = - DefuncError k (flags1 .&. flags2) pOff uOff (Op (Merged k err1 err2)) + DefuncError k (flags1 .&. flags2) pOff uOff (Op (Merged err1 err2)) -- FLAG MASKS {-# INLINE vanillaBit #-} diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs index 90ce9fb9..e7a4c1b4 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs @@ -55,25 +55,16 @@ data BaseError k where type ErrorOp :: ErrKind -> UnliftedDatatype data ErrorOp k where - Merged :: {-# UNPACK #-} !(ErrKindSingleton k) - -> {-# UNPACK #-} !(DefuncError_ k) -> {-# UNPACK #-} !(DefuncError_ k) -> ErrorOp k + Merged :: {-# UNPACK #-} !(DefuncError_ k) -> {-# UNPACK #-} !(DefuncError_ k) -> ErrorOp k AdjustCaret :: {-# UNPACK #-} !(DefuncError_ 'Specialised) -> {-# UNPACK #-} !(DefuncError_ 'Vanilla) -- ^ caretAdjuster -> ErrorOp 'Specialised WithHints :: {-# UNPACK #-} !(DefuncError_ 'Vanilla) -> !DefuncHints -> ErrorOp 'Vanilla WithReason :: {-# UNPACK #-} !(DefuncError_ 'Vanilla) -> !String -> ErrorOp 'Vanilla WithLabel :: {-# UNPACK #-} !(DefuncError_ 'Vanilla) -> !(Set String) -> ErrorOp 'Vanilla - Amended :: {-# UNPACK #-} !(ErrKindSingleton k) - -> {-# UNPACK #-} !Word -- ^ line + Amended :: {-# UNPACK #-} !Word -- ^ line -> {-# UNPACK #-} !Word -- ^ col -> {-# UNPACK #-} !(DefuncError_ k) -> ErrorOp k - {-Entrenched :: {-# UNPACK #-} !(ErrKindSingleton k) - -> {-# UNPACK #-} !Word32 -- ^ by - -> {-# UNPACK #-} !(DefuncError_ k) -> ErrorOp k - Dislodged :: {-# UNPACK #-} !(ErrKindSingleton k) - -> {-# UNPACK #-} !Word32 -- ^ by - -> {-# UNPACK #-} !(DefuncError_ k) -> ErrorOp k-} - Lexical :: {-# UNPACK #-} !(DefuncError_ 'Vanilla) -> ErrorOp 'Vanilla type DefuncHints :: UnliftedDatatype data DefuncHints where From 4eb081361b621af354ad2d4a99c7482db7344130 Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Fri, 26 Jan 2024 16:05:57 +0000 Subject: [PATCH 07/25] refactor(Internal): inlined mergeSame and adjustCaret --- .../Gigaparsec/Internal/Errors/DefuncError.hs | 30 +++++++------------ 1 file changed, 11 insertions(+), 19 deletions(-) diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs index b4b67491..434b0aa2 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs @@ -14,7 +14,7 @@ import Data.Set (Set) import Data.Set qualified as Set (null) import Text.Gigaparsec.Internal.Errors.DefuncTypes ( - DefuncError(..), DefuncError_(..), ErrKindSingleton(..), ErrorOp(..), ErrKind(..), + DefuncError(..), DefuncError_(..), ErrKindSingleton(..), ErrorOp(..), DefuncHints(..) ) @@ -50,17 +50,19 @@ merge err1 err2 = case compare (underlyingOffset err1) (underlyingOffset err2) o GT -> err1 LT -> err2 EQ -> case err1 of - DefuncError IsSpecialised _ _ _ errTy1 - | DefuncError IsSpecialised _ _ _ errTy2 <- err2 -> - mergeSame err1 (flags err2) IsSpecialised errTy1 errTy2 + DefuncError IsSpecialised flags1 pOff uOff errTy1 + | DefuncError IsSpecialised flags2 _ _ errTy2 <- err2 -> + DefuncError IsSpecialised (flags1 .&. flags2) pOff uOff (Op (Merged errTy1 errTy2)) | DefuncError IsVanilla _ _ _ errTy2 <- err2 - , isFlexibleCaret err1 -> adjustCaret err1 errTy1 errTy2 + , isFlexibleCaret err1 -> + DefuncError IsSpecialised flags1 pOff uOff (Op (AdjustCaret errTy1 errTy2)) | otherwise -> err1 - DefuncError IsVanilla _ _ _ errTy1 - | DefuncError IsVanilla _ _ _ errTy2 <- err2 -> - mergeSame err1 (flags err2) IsVanilla errTy1 errTy2 + DefuncError IsVanilla flags1 pOff uOff errTy1 + | DefuncError IsVanilla flags2 _ _ errTy2 <- err2 -> + DefuncError IsVanilla (flags1 .&. flags2) pOff uOff (Op (Merged errTy1 errTy2)) | DefuncError IsSpecialised _ _ _ errTy2 <- err2 - , isFlexibleCaret err2 -> adjustCaret err1 errTy2 errTy1 + , isFlexibleCaret err2 -> + DefuncError IsSpecialised flags1 pOff uOff (Op (AdjustCaret errTy2 errTy1)) | otherwise -> err2 withHints :: DefuncHints -> DefuncError -> DefuncError @@ -107,16 +109,6 @@ markAsLexical !off (DefuncError IsVanilla flags pOff uOff errTy) | off == pOff = DefuncError IsVanilla (setBit flags lexicalBit) pOff uOff errTy markAsLexical _ err = err -{-# INLINABLE adjustCaret #-} -adjustCaret :: DefuncError -> DefuncError_ 'Specialised -> DefuncError_ 'Vanilla -> DefuncError -adjustCaret (DefuncError _ flags pOff uOff _) err1 err2 = - DefuncError IsSpecialised flags pOff uOff (Op (AdjustCaret err1 err2)) - -{-# INLINABLE mergeSame #-} -mergeSame :: DefuncError -> Word32 -> ErrKindSingleton k -> DefuncError_ k -> DefuncError_ k -> DefuncError -mergeSame (DefuncError _ flags1 pOff uOff _) !flags2 k err1 err2 = - DefuncError k (flags1 .&. flags2) pOff uOff (Op (Merged err1 err2)) - -- FLAG MASKS {-# INLINE vanillaBit #-} {-# INLINE expectedEmptyBit #-} From cf57a2a3f357453e56eb19d82fa9aa70c47b6026 Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Fri, 26 Jan 2024 16:20:36 +0000 Subject: [PATCH 08/25] refactor(Internal): simplified merge logic --- .../Gigaparsec/Internal/Errors/DefuncError.hs | 38 +++++++++---------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs index 434b0aa2..df1115bf 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs @@ -43,27 +43,27 @@ isLexical :: DefuncError -> Bool isLexical DefuncError{flags} = testBit flags lexicalBit merge :: DefuncError -> DefuncError -> DefuncError -merge err1 err2 = case compare (underlyingOffset err1) (underlyingOffset err2) of - GT -> err1 - LT -> err2 - EQ -> case compare (presentationOffset err1) (presentationOffset err2) of +merge err1@(DefuncError k1 flags1 pOff1 uOff1 errTy1) + err2@(DefuncError k2 flags2 pOff2 uOff2 errTy2) = + case compare uOff1 uOff2 of GT -> err1 LT -> err2 - EQ -> case err1 of - DefuncError IsSpecialised flags1 pOff uOff errTy1 - | DefuncError IsSpecialised flags2 _ _ errTy2 <- err2 -> - DefuncError IsSpecialised (flags1 .&. flags2) pOff uOff (Op (Merged errTy1 errTy2)) - | DefuncError IsVanilla _ _ _ errTy2 <- err2 - , isFlexibleCaret err1 -> - DefuncError IsSpecialised flags1 pOff uOff (Op (AdjustCaret errTy1 errTy2)) - | otherwise -> err1 - DefuncError IsVanilla flags1 pOff uOff errTy1 - | DefuncError IsVanilla flags2 _ _ errTy2 <- err2 -> - DefuncError IsVanilla (flags1 .&. flags2) pOff uOff (Op (Merged errTy1 errTy2)) - | DefuncError IsSpecialised _ _ _ errTy2 <- err2 - , isFlexibleCaret err2 -> - DefuncError IsSpecialised flags1 pOff uOff (Op (AdjustCaret errTy2 errTy1)) - | otherwise -> err2 + EQ -> case compare pOff1 pOff2 of + GT -> err1 + LT -> err2 + EQ -> case k1 of + IsSpecialised -> case k2 of + IsSpecialised -> + DefuncError IsSpecialised (flags1 .&. flags2) pOff1 uOff1 (Op (Merged errTy1 errTy2)) + IsVanilla | isFlexibleCaret err1 -> + DefuncError IsSpecialised flags1 pOff1 uOff1 (Op (AdjustCaret errTy1 errTy2)) + _ -> err1 + IsVanilla -> case k2 of + IsVanilla -> + DefuncError IsVanilla (flags1 .&. flags2) pOff1 uOff1 (Op (Merged errTy1 errTy2)) + IsSpecialised | isFlexibleCaret err2 -> + DefuncError IsSpecialised flags1 pOff1 uOff1 (Op (AdjustCaret errTy2 errTy1)) + _ -> err2 withHints :: DefuncHints -> DefuncError -> DefuncError withHints Blank err = err From 393b546bf27e1f08f6a08983d088052619be48a4 Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Fri, 26 Jan 2024 16:48:59 +0000 Subject: [PATCH 09/25] feat(Internal): added error constructors --- .../Gigaparsec/Internal/Errors/DefuncError.hs | 40 ++++++++++++++++++- .../Gigaparsec/Internal/Errors/DefuncTypes.hs | 4 +- 2 files changed, 39 insertions(+), 5 deletions(-) diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs index df1115bf..298c87c9 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs @@ -3,20 +3,24 @@ {-# OPTIONS_GHC -Wno-missing-import-lists #-} module Text.Gigaparsec.Internal.Errors.DefuncError ( DefuncError, + specialisedError, expectedError, unexpectedError, emptyError, merge, withHints, withReason, withReasonAndOffset, label, amend, entrench, dislodge, markAsLexical, isVanilla, isExpectedEmpty, isLexical ) where import Data.Word (Word32) -import Data.Bits ((.&.), testBit, clearBit, setBit, complement) +import Data.Bits ((.&.), testBit, clearBit, setBit, complement, bit) import Data.Set (Set) import Data.Set qualified as Set (null) +import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth, Span, isFlexible) import Text.Gigaparsec.Internal.Errors.DefuncTypes ( - DefuncError(..), DefuncError_(..), ErrKindSingleton(..), ErrorOp(..), + DefuncError(..), DefuncError_(..), ErrKindSingleton(..), + ErrorOp(..), BaseError(..), DefuncHints(..) ) +import Text.Gigaparsec.Internal.Errors.ErrorItem (ExpectItem) {-# INLINABLE isVanilla #-} isVanilla :: DefuncError -> Bool @@ -42,6 +46,38 @@ isFlexibleCaret DefuncError{flags} = testBit flags flexibleCaretBit isLexical :: DefuncError -> Bool isLexical DefuncError{flags} = testBit flags lexicalBit +-- Base Errors +specialisedError :: Word -> Word -> Word -> [String] -> CaretWidth -> DefuncError +specialisedError !pOff !line !col !msgs caret = + DefuncError IsSpecialised flags pOff pOff (Base line col (ClassicSpecialised msgs caret)) + where flags :: Word32 + !flags + | isFlexible caret = setBit (bit expectedEmptyBit) flexibleCaretBit + | otherwise = bit expectedEmptyBit + +emptyError :: Word -> Word -> Word -> Span -> DefuncError +emptyError !pOff !line !col !unexWidth = + DefuncError IsVanilla flags pOff pOff (Base line col (Empty unexWidth)) + where flags :: Word32 + !flags = setBit (bit vanillaBit) expectedEmptyBit + +expectedError :: Word -> Word -> Word -> Set ExpectItem -> Span -> DefuncError +expectedError !pOff !line !col !exs !unexWidth = + DefuncError IsVanilla flags pOff pOff (Base line col (Expected exs unexWidth)) + where flags :: Word32 + !flags + | Set.null exs = setBit (bit vanillaBit) expectedEmptyBit + | otherwise = bit vanillaBit + +unexpectedError :: Word -> Word -> Word -> Set ExpectItem -> String -> CaretWidth -> DefuncError +unexpectedError !pOff !line !col !exs !unex caretWidth = + DefuncError IsVanilla flags pOff pOff (Base line col (Unexpected exs unex caretWidth)) + where flags :: Word32 + !flags + | Set.null exs = setBit (bit vanillaBit) expectedEmptyBit + | otherwise = bit vanillaBit + +-- Operations merge :: DefuncError -> DefuncError -> DefuncError merge err1@(DefuncError k1 flags1 pOff1 uOff1 errTy1) err2@(DefuncError k2 flags2 pOff2 uOff2 errTy2) = diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs index e7a4c1b4..70de8815 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs @@ -46,12 +46,10 @@ data DefuncError_ k where type BaseError :: ErrKind -> UnliftedDatatype data BaseError k where - ClassicSpecialised :: ![String] -> BaseError 'Specialised + ClassicSpecialised :: ![String] -> {-# UNPACK #-} !CaretWidth -> BaseError 'Specialised Expected :: !(Set ExpectItem) -> {-# UNPACK #-} !Span -> BaseError 'Vanilla - ExpectedWithReason :: !(Set ExpectItem) -> !String -> {-# UNPACK #-} !Span -> BaseError 'Vanilla Unexpected :: !(Set ExpectItem) -> !String -> {-# UNPACK #-} !CaretWidth -> BaseError 'Vanilla Empty :: {-# UNPACK #-} !Span -> BaseError 'Vanilla - EmptyWithReason :: !String -> {-# UNPACK #-} !Span -> BaseError 'Vanilla type ErrorOp :: ErrKind -> UnliftedDatatype data ErrorOp k where From 66ed0abd4b616fb2cce84f619243a423a07b813b Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Fri, 26 Jan 2024 17:02:11 +0000 Subject: [PATCH 10/25] refactor(Internal): removed unneeded records --- src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs index 70de8815..0ddc344d 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs @@ -1,6 +1,5 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE BangPatterns, CPP, DataKinds, GADTs #-} -{-# OPTIONS_GHC -Wno-partial-fields -Wno-all-missed-specialisations -Wno-missing-import-lists #-} {-# OPTIONS_HADDOCK hide #-} -- Yes, this is redundant, however, it is necessary to get the UNPACK to fire {-# OPTIONS_GHC -Wno-redundant-strictness-flags #-} @@ -36,12 +35,11 @@ data DefuncError = forall k. DefuncError { type DefuncError_ :: ErrKind -> UnliftedDatatype data DefuncError_ k where - Base :: { line :: {-# UNPACK #-} !Word - , col :: {-# UNPACK #-} !Word - , base :: {-# UNPACK #-} !(BaseError k) - } + Base :: {-# UNPACK #-} !Word -- ^ line + -> {-# UNPACK #-} !Word -- ^ col + -> {-# UNPACK #-} !(BaseError k) -> DefuncError_ k - Op :: { op :: {-# UNPACK #-} !(ErrorOp k) } -> DefuncError_ k + Op :: {-# UNPACK #-} !(ErrorOp k) -> DefuncError_ k type BaseError :: ErrKind -> UnliftedDatatype From 5954f5f0af20b576c5124eccd9f198bf0fe95dac Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Fri, 26 Jan 2024 18:17:53 +0000 Subject: [PATCH 11/25] wip(Internal): added most of vanilla builder --- gigaparsec.cabal | 1 + .../Internal/Errors/DefuncBuilders.hs | 79 +++++++++++++++++++ 2 files changed, 80 insertions(+) create mode 100644 src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs diff --git a/gigaparsec.cabal b/gigaparsec.cabal index cc1c7b5c..dda436bb 100644 --- a/gigaparsec.cabal +++ b/gigaparsec.cabal @@ -103,6 +103,7 @@ library Text.Gigaparsec.Internal, Text.Gigaparsec.Internal.Errors, Text.Gigaparsec.Internal.Errors.CaretControl, + Text.Gigaparsec.Internal.Errors.DefuncBuilders, Text.Gigaparsec.Internal.Errors.DefuncError, Text.Gigaparsec.Internal.Errors.DefuncTypes, Text.Gigaparsec.Internal.Errors.ErrorItem, diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs new file mode 100644 index 00000000..f4460d0b --- /dev/null +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE GADTs, DataKinds, UnboxedTuples #-} +module Text.Gigaparsec.Internal.Errors.DefuncBuilders ( + --module Text.Gigaparsec.Internal.Errors.DefuncBuilders + asParseError + ) where + +import Text.Gigaparsec.Internal.Errors.DefuncTypes +import Text.Gigaparsec.Internal.Errors (ParseError(VanillaError, SpecialisedError), CaretWidth) +import Text.Gigaparsec.Internal.Errors.DefuncError (isLexical) +import Text.Gigaparsec.Internal.Errors.ErrorItem + +import Data.Set (Set) +import Data.Set qualified as Set + +asParseError :: DefuncError -> ParseError +asParseError e@DefuncError{..} = case errKind of + IsVanilla -> case makeVanilla 0 0 Set.empty EmptyItem Set.empty True errTy of + (# line, col, exs, unex, reasons #) -> + VanillaError presentationOffset line col (toErrorItem unex) exs reasons (isLexical e) 0 0 + IsSpecialised -> undefined + where + makeVanilla :: Word -> Word -> Set ExpectItem -> BuilderUnexpectItem -> Set String -> Bool + -> DefuncError_ 'Vanilla + -> (# Word, Word, Set ExpectItem, BuilderUnexpectItem, Set String #) + makeVanilla !_ !_ !exs !unex !reasons !acceptingExpected (Base line col err) = + case err of + Empty unexWidth -> + (# line, col, exs, updateEmptyUnexpected unexWidth unex, reasons #) + Expected exs' unexWidth -> + (# line, col, addLabels acceptingExpected exs exs', updateUnexpected unexWidth unex, reasons #) + Unexpected exs' unex' caretWidth -> + (# line, col, addLabels acceptingExpected exs exs', updateUnexpected' unex' caretWidth unex, reasons #) + makeVanilla line col exs unex reasons acceptingExpected (Op op) = + case op of + Merged err1 err2 -> + case makeVanilla line col exs unex reasons acceptingExpected err1 of + (# line', col', exs', unex', reasons' #) -> + makeVanilla line' col' exs' unex' reasons' acceptingExpected err2 + WithHints err hints -> + case makeVanilla line col exs unex reasons acceptingExpected err of + (# line', col', exs', unex', reasons' #) -> + {- + builder.whenAcceptingExpected { + for (size <- hints.updateExpectedsAndGetSize(builder)) builder.updateUnexpected(size) + } + -} + undefined + WithLabel err ls -> + case makeVanilla line col exs unex reasons False err of + (# line', col', exs', unex', reasons' #) -> + (# line', col', addLabels acceptingExpected exs' (Set.map ExpectNamed ls), unex', reasons' #) + WithReason err reason -> + makeVanilla line col exs unex (Set.insert reason reasons) acceptingExpected err + Amended line' col' err -> + case makeVanilla line col exs unex reasons acceptingExpected err of + (# _, _, exs', unex', reasons' #) -> + (# line', col', exs', unex', reasons' #) + +-- FIXME: unlifted +type BuilderUnexpectItem :: * +data BuilderUnexpectItem = + EmptyItem + +updateEmptyUnexpected :: Word -> BuilderUnexpectItem -> BuilderUnexpectItem +updateEmptyUnexpected _ _ = undefined -- TODO: + +updateUnexpected :: Word -> BuilderUnexpectItem -> BuilderUnexpectItem +updateUnexpected _ _ = undefined -- TODO: + +updateUnexpected' :: String -> CaretWidth -> BuilderUnexpectItem -> BuilderUnexpectItem +updateUnexpected' _ _ _ = undefined -- TODO: + +addLabels :: Bool -> Set ExpectItem -> Set ExpectItem -> Set ExpectItem +addLabels True !exs !exs' = Set.union exs exs' +addLabels False exs _ = exs + +toErrorItem :: BuilderUnexpectItem -> Either Word UnexpectItem +toErrorItem _ = undefined -- TODO: From bde402845baf1c55f2e261dc9e59c8358eab797a Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Sat, 27 Jan 2024 13:11:20 +0000 Subject: [PATCH 12/25] feat(Internal): added vanilla builders --- .../Internal/Errors/CaretControl.hs | 1 + .../Internal/Errors/DefuncBuilders.hs | 124 ++++++++++++++---- .../Gigaparsec/Internal/Errors/DefuncError.hs | 1 + .../Gigaparsec/Internal/Errors/DefuncTypes.hs | 16 ++- 4 files changed, 115 insertions(+), 27 deletions(-) diff --git a/src/Text/Gigaparsec/Internal/Errors/CaretControl.hs b/src/Text/Gigaparsec/Internal/Errors/CaretControl.hs index 3f054ae5..85ca60a5 100644 --- a/src/Text/Gigaparsec/Internal/Errors/CaretControl.hs +++ b/src/Text/Gigaparsec/Internal/Errors/CaretControl.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} #include "portable-unlifted.h" module Text.Gigaparsec.Internal.Errors.CaretControl ( module Text.Gigaparsec.Internal.Errors.CaretControl diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs index f4460d0b..0b0f1a5a 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs @@ -1,34 +1,56 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE GADTs, DataKinds, UnboxedTuples #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE GADTs, DataKinds, UnboxedTuples, UnboxedSums, PatternSynonyms, CPP #-} +{-# OPTIONS_HADDOCK hide #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +-- Yes, this is redundant, however, it is necessary to get the UNPACK to fire +{-# OPTIONS_GHC -Wno-redundant-strictness-flags #-} +#include "portable-unlifted.h" module Text.Gigaparsec.Internal.Errors.DefuncBuilders ( - --module Text.Gigaparsec.Internal.Errors.DefuncBuilders asParseError ) where -import Text.Gigaparsec.Internal.Errors.DefuncTypes +import Text.Gigaparsec.Internal.Errors.DefuncTypes ( + DefuncHints(Blank, Merge, AddErr, Replace), + ErrorOp(Amended, WithLabel, WithHints, Merged, WithReason), + BaseError(Unexpected, Empty, Expected), + DefuncError_(Op, Base), + DefuncError(DefuncError, presentationOffset, errKind, errTy), + ErrKindSingleton(IsSpecialised, IsVanilla), + ErrKind(Vanilla), + expecteds, unexpectedWidth + ) import Text.Gigaparsec.Internal.Errors (ParseError(VanillaError, SpecialisedError), CaretWidth) import Text.Gigaparsec.Internal.Errors.DefuncError (isLexical) -import Text.Gigaparsec.Internal.Errors.ErrorItem +import Text.Gigaparsec.Internal.Errors.ErrorItem ( + ExpectItem(ExpectNamed), + UnexpectItem(UnexpectEndOfInput, UnexpectNamed, UnexpectRaw) + ) import Data.Set (Set) import Data.Set qualified as Set +import Data.List.NonEmpty (nonEmpty) -asParseError :: DefuncError -> ParseError -asParseError e@DefuncError{..} = case errKind of - IsVanilla -> case makeVanilla 0 0 Set.empty EmptyItem Set.empty True errTy of +CPP_import_PortableUnlifted +import GHC.Exts (TYPE, RuntimeRep(SumRep), LiftedRep, ZeroBitRep) + +asParseError :: String -> DefuncError -> ParseError +asParseError !input e@DefuncError{..} = case errKind of + IsVanilla -> case makeVanilla 0 0 Set.empty (NoItem 0) Set.empty True errTy of (# line, col, exs, unex, reasons #) -> - VanillaError presentationOffset line col (toErrorItem unex) exs reasons (isLexical e) 0 0 + VanillaError presentationOffset line col (toErrorItem input presentationOffset unex) exs reasons (isLexical e) 0 0 IsSpecialised -> undefined where + !outOfRange = presentationOffset < fromIntegral (length input) + makeVanilla :: Word -> Word -> Set ExpectItem -> BuilderUnexpectItem -> Set String -> Bool -> DefuncError_ 'Vanilla -> (# Word, Word, Set ExpectItem, BuilderUnexpectItem, Set String #) - makeVanilla !_ !_ !exs !unex !reasons !acceptingExpected (Base line col err) = + makeVanilla !_ !_ !exs unex !reasons !acceptingExpected (Base line col err) = case err of Empty unexWidth -> (# line, col, exs, updateEmptyUnexpected unexWidth unex, reasons #) Expected exs' unexWidth -> - (# line, col, addLabels acceptingExpected exs exs', updateUnexpected unexWidth unex, reasons #) + (# line, col, addLabels acceptingExpected exs exs', updateUnexpected outOfRange unexWidth unex, reasons #) Unexpected exs' unex' caretWidth -> (# line, col, addLabels acceptingExpected exs exs', updateUnexpected' unex' caretWidth unex, reasons #) makeVanilla line col exs unex reasons acceptingExpected (Op op) = @@ -40,12 +62,12 @@ asParseError e@DefuncError{..} = case errKind of WithHints err hints -> case makeVanilla line col exs unex reasons acceptingExpected err of (# line', col', exs', unex', reasons' #) -> - {- - builder.whenAcceptingExpected { - for (size <- hints.updateExpectedsAndGetSize(builder)) builder.updateUnexpected(size) - } - -} - undefined + if acceptingExpected then + case collectHints exs' UNothing hints of + (# exs'', UJust width #) -> + (# line', col', exs'', updateUnexpected outOfRange width unex', reasons' #) + (# exs'', UNothing #) -> (# line', col', exs'', unex', reasons' #) + else (# line', col', exs', unex', reasons' #) WithLabel err ls -> case makeVanilla line col exs unex reasons False err of (# line', col', exs', unex', reasons' #) -> @@ -58,22 +80,72 @@ asParseError e@DefuncError{..} = case errKind of (# line', col', exs', unex', reasons' #) -- FIXME: unlifted -type BuilderUnexpectItem :: * -data BuilderUnexpectItem = - EmptyItem +type BuilderUnexpectItem :: UnliftedDatatype +data BuilderUnexpectItem = NoItem {-# UNPACK #-} !Word + | RawItem {-# UNPACK #-} !Word + | NamedItem !String {-# UNPACK #-} !CaretWidth + | EndOfInput updateEmptyUnexpected :: Word -> BuilderUnexpectItem -> BuilderUnexpectItem -updateEmptyUnexpected _ _ = undefined -- TODO: +updateEmptyUnexpected !w = pickHigher (NoItem w) -updateUnexpected :: Word -> BuilderUnexpectItem -> BuilderUnexpectItem -updateUnexpected _ _ = undefined -- TODO: +updateUnexpected :: Bool -> Word -> BuilderUnexpectItem -> BuilderUnexpectItem +updateUnexpected !outOfRange !w + | outOfRange = pickHigher EndOfInput + | otherwise = pickHigher (RawItem w) updateUnexpected' :: String -> CaretWidth -> BuilderUnexpectItem -> BuilderUnexpectItem -updateUnexpected' _ _ _ = undefined -- TODO: +updateUnexpected' item cw = pickHigher (NamedItem item cw) + +pickHigher :: BuilderUnexpectItem -> BuilderUnexpectItem -> BuilderUnexpectItem +pickHigher _ _ = undefined addLabels :: Bool -> Set ExpectItem -> Set ExpectItem -> Set ExpectItem addLabels True !exs !exs' = Set.union exs exs' addLabels False exs _ = exs -toErrorItem :: BuilderUnexpectItem -> Either Word UnexpectItem -toErrorItem _ = undefined -- TODO: +toErrorItem :: String -> Word -> BuilderUnexpectItem -> Either Word UnexpectItem +toErrorItem !_ !_ (NoItem w) = Left w +toErrorItem _ _ (NamedItem item cw) = Right (UnexpectNamed item cw) +toErrorItem _ _ EndOfInput = Right UnexpectEndOfInput +toErrorItem input off (RawItem w) = + case nonEmpty (drop (fromIntegral off) input) of + Nothing -> Right UnexpectEndOfInput + Just cs -> Right (UnexpectRaw cs w) + +type UMaybe :: * -> TYPE ('SumRep '[ZeroBitRep, LiftedRep]) +type UMaybe a = (# (# #) | a #) +{-# COMPLETE UJust, UNothing #-} +pattern UJust :: a -> UMaybe a +pattern UJust x = (# | x #) +pattern UNothing :: UMaybe a +pattern UNothing = (# (# #) | #) + +collectHints :: Set ExpectItem -> UMaybe Word -> DefuncHints -> (# Set ExpectItem, UMaybe Word #) +collectHints !exs width Blank = (# exs, width #) +collectHints exs width (Replace ls) = (# Set.union exs (Set.map ExpectNamed ls), width #) +collectHints exs width (Merge hints1 hints2) = + let !(# exs', width' #) = collectHints exs width hints1 + in collectHints exs' width' hints2 +collectHints exs width (AddErr hints err) = + let !(# exs', width' #) = collectHintsErr exs width err + in collectHints exs' width' hints + +collectHintsErr :: Set ExpectItem -> UMaybe Word -> DefuncError_ 'Vanilla -> (# Set ExpectItem, UMaybe Word #) +collectHintsErr !exs width (Base _ _ err) = + (# Set.union exs (expecteds err), updateWidth width (unexpectedWidth err) #) +collectHintsErr exs width (Op op) = case op of + -- FIXME: Why doesn't this traverse deeper to collect the width? + WithLabel _ ls -> (# Set.union exs (Set.map ExpectNamed ls), width #) + WithHints err hints -> + let !(# exs', width' #) = collectHints exs width hints + in collectHintsErr exs' width' err + Merged err1 err2 -> + let !(# exs', width' #) = collectHintsErr exs width err1 + in collectHintsErr exs' width' err2 + WithReason err _ -> collectHintsErr exs width err + Amended _ _ err -> collectHintsErr exs width err + +updateWidth :: UMaybe Word -> Word -> UMaybe Word +updateWidth UNothing !w = UJust w +updateWidth (UJust w) w' = UJust (max w w') diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs index 298c87c9..223e5e59 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE GADTs, NamedFieldPuns, BinaryLiterals, NumericUnderscores, DataKinds, BangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_GHC -Wno-missing-import-lists #-} module Text.Gigaparsec.Internal.Errors.DefuncError ( DefuncError, diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs index 0ddc344d..74249998 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs @@ -8,11 +8,12 @@ module Text.Gigaparsec.Internal.Errors.DefuncTypes ( module Text.Gigaparsec.Internal.Errors.DefuncTypes ) where -import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth, Span) +import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth (width), Span) import Text.Gigaparsec.Internal.Errors.ErrorItem (ExpectItem) import Data.Word (Word32) import Data.Set (Set) +import Data.Set qualified as Set (empty) CPP_import_PortableUnlifted @@ -49,6 +50,19 @@ data BaseError k where Unexpected :: !(Set ExpectItem) -> !String -> {-# UNPACK #-} !CaretWidth -> BaseError 'Vanilla Empty :: {-# UNPACK #-} !Span -> BaseError 'Vanilla +{-# INLINABLE expecteds #-} +expecteds :: BaseError 'Vanilla -> Set ExpectItem +expecteds (Expected exs _) = exs +expecteds (Unexpected exs _ _) = exs +expecteds Empty{} = Set.empty + +{-# INLINEABLE unexpectedWidth #-} +unexpectedWidth :: BaseError 'Vanilla -> Word +unexpectedWidth (Expected _ w) = w +unexpectedWidth (Unexpected _ _ cw) = width cw +unexpectedWidth (Empty w) = w + + type ErrorOp :: ErrKind -> UnliftedDatatype data ErrorOp k where Merged :: {-# UNPACK #-} !(DefuncError_ k) -> {-# UNPACK #-} !(DefuncError_ k) -> ErrorOp k From 5b50b07dfe230eb7d2ac91c16ea6ca7b7acfaa15 Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Sat, 27 Jan 2024 13:19:31 +0000 Subject: [PATCH 13/25] fixed old GHCs --- src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs index 0b0f1a5a..5e4a2832 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs @@ -3,7 +3,7 @@ {-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_GHC -Wno-unused-imports #-} -- Yes, this is redundant, however, it is necessary to get the UNPACK to fire -{-# OPTIONS_GHC -Wno-redundant-strictness-flags #-} +{-# OPTIONS_GHC -Wno-redundant-strictness-flags -Wno-missing-kind-signatures #-} #include "portable-unlifted.h" module Text.Gigaparsec.Internal.Errors.DefuncBuilders ( asParseError @@ -79,7 +79,6 @@ asParseError !input e@DefuncError{..} = case errKind of (# _, _, exs', unex', reasons' #) -> (# line', col', exs', unex', reasons' #) --- FIXME: unlifted type BuilderUnexpectItem :: UnliftedDatatype data BuilderUnexpectItem = NoItem {-# UNPACK #-} !Word | RawItem {-# UNPACK #-} !Word @@ -98,7 +97,7 @@ updateUnexpected' :: String -> CaretWidth -> BuilderUnexpectItem -> BuilderUnexp updateUnexpected' item cw = pickHigher (NamedItem item cw) pickHigher :: BuilderUnexpectItem -> BuilderUnexpectItem -> BuilderUnexpectItem -pickHigher _ _ = undefined +pickHigher _ _ = undefined -- TODO: addLabels :: Bool -> Set ExpectItem -> Set ExpectItem -> Set ExpectItem addLabels True !exs !exs' = Set.union exs exs' @@ -113,7 +112,6 @@ toErrorItem input off (RawItem w) = Nothing -> Right UnexpectEndOfInput Just cs -> Right (UnexpectRaw cs w) -type UMaybe :: * -> TYPE ('SumRep '[ZeroBitRep, LiftedRep]) type UMaybe a = (# (# #) | a #) {-# COMPLETE UJust, UNothing #-} pattern UJust :: a -> UMaybe a From fe74a255a7d41f57779b8850f1dbe8efeb3f239c Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Sat, 27 Jan 2024 13:22:23 +0000 Subject: [PATCH 14/25] fix(Internal): removed unneeded errors --- src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs index 5e4a2832..b8f52b5c 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs @@ -31,7 +31,6 @@ import Data.Set qualified as Set import Data.List.NonEmpty (nonEmpty) CPP_import_PortableUnlifted -import GHC.Exts (TYPE, RuntimeRep(SumRep), LiftedRep, ZeroBitRep) asParseError :: String -> DefuncError -> ParseError asParseError !input e@DefuncError{..} = case errKind of From b8569279ac8116451807452775a95a74c47da79b Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Sat, 27 Jan 2024 14:43:15 +0000 Subject: [PATCH 15/25] completed the building process --- .../Internal/Errors/DefuncBuilders.hs | 82 +++++++++++++++++-- 1 file changed, 75 insertions(+), 7 deletions(-) diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs index b8f52b5c..1eb28f3c 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs @@ -11,15 +11,16 @@ module Text.Gigaparsec.Internal.Errors.DefuncBuilders ( import Text.Gigaparsec.Internal.Errors.DefuncTypes ( DefuncHints(Blank, Merge, AddErr, Replace), - ErrorOp(Amended, WithLabel, WithHints, Merged, WithReason), - BaseError(Unexpected, Empty, Expected), + ErrorOp(Amended, WithLabel, WithHints, Merged, WithReason, AdjustCaret), + BaseError(Unexpected, Empty, Expected, ClassicSpecialised), DefuncError_(Op, Base), DefuncError(DefuncError, presentationOffset, errKind, errTy), ErrKindSingleton(IsSpecialised, IsVanilla), - ErrKind(Vanilla), + ErrKind(Vanilla, Specialised), expecteds, unexpectedWidth ) -import Text.Gigaparsec.Internal.Errors (ParseError(VanillaError, SpecialisedError), CaretWidth) +import Text.Gigaparsec.Internal.Errors (ParseError(VanillaError, SpecialisedError)) +import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth(FlexibleCaret, width), isFlexible) import Text.Gigaparsec.Internal.Errors.DefuncError (isLexical) import Text.Gigaparsec.Internal.Errors.ErrorItem ( ExpectItem(ExpectNamed), @@ -27,7 +28,7 @@ import Text.Gigaparsec.Internal.Errors.ErrorItem ( ) import Data.Set (Set) -import Data.Set qualified as Set +import Data.Set qualified as Set (empty, insert, union, member, map) import Data.List.NonEmpty (nonEmpty) CPP_import_PortableUnlifted @@ -37,7 +38,9 @@ asParseError !input e@DefuncError{..} = case errKind of IsVanilla -> case makeVanilla 0 0 Set.empty (NoItem 0) Set.empty True errTy of (# line, col, exs, unex, reasons #) -> VanillaError presentationOffset line col (toErrorItem input presentationOffset unex) exs reasons (isLexical e) 0 0 - IsSpecialised -> undefined + IsSpecialised -> case makeSpec 0 0 0 True id errTy of + (# line, col, width, _, dmsgs #) -> + SpecialisedError presentationOffset line col (distinct (dmsgs [])) (FlexibleCaret width) 0 0 where !outOfRange = presentationOffset < fromIntegral (length input) @@ -78,6 +81,25 @@ asParseError !input e@DefuncError{..} = case errKind of (# _, _, exs', unex', reasons' #) -> (# line', col', exs', unex', reasons' #) + makeSpec :: Word -> Word -> Word -> Bool -> ([String] -> [String]) + -> DefuncError_ 'Specialised + -> (# Word, Word, Word, Bool, [String] -> [String] #) + makeSpec !_ !_ !w !flexible !dmsgs (Base line col (ClassicSpecialised msgs cw)) = + let (# w', flexible' #) = updateCaretWidth flexible cw w + in (# line, col, w', flexible', dmsgs . (msgs ++) #) + makeSpec line col w flexible dmsgs (Op op) = case op of + Merged err1 err2-> + case makeSpec line col w flexible dmsgs err1 of + (# line', col', w', flexible', dmsgs' #) -> + makeSpec line' col' w' flexible' dmsgs' err2 + AdjustCaret err1 err2 -> + case makeSpec line col w flexible dmsgs err1 of + (# line', col', w', flexible', dmsgs' #) -> + -- assuming flexible == True + (# line', col', adjustCaret w' err2, flexible', dmsgs' #) + Amended line' col' err -> case makeSpec line col w flexible dmsgs err of + (# _, _, w', flexible', dmsgs' #) -> (# line', col', w', flexible', dmsgs' #) + type BuilderUnexpectItem :: UnliftedDatatype data BuilderUnexpectItem = NoItem {-# UNPACK #-} !Word | RawItem {-# UNPACK #-} !Word @@ -96,7 +118,29 @@ updateUnexpected' :: String -> CaretWidth -> BuilderUnexpectItem -> BuilderUnexp updateUnexpected' item cw = pickHigher (NamedItem item cw) pickHigher :: BuilderUnexpectItem -> BuilderUnexpectItem -> BuilderUnexpectItem -pickHigher _ _ = undefined -- TODO: +pickHigher EndOfInput _ = EndOfInput +pickHigher _ EndOfInput = EndOfInput +pickHigher x@(RawItem w1) y@(RawItem w2) + | w1 > w2 = x + | otherwise = y +pickHigher x@(NoItem w1) y@(NoItem w2) + | w1 > w2 = x + | otherwise = y +pickHigher x@(NamedItem _ cw1) y@(NamedItem _ cw2) + | isFlexible cw1 /= isFlexible cw2 = if isFlexible cw1 then x else y + | width cw1 > width cw2 = x + | otherwise = y +pickHigher x@(RawItem w1) (NoItem w2) + | w1 > w2 = x + | otherwise = RawItem w2 +pickHigher x@(NamedItem name (FlexibleCaret w1)) (RawItem w2) + | w1 > w2 = x + | otherwise = NamedItem name (FlexibleCaret w2) +pickHigher x@(NamedItem name (FlexibleCaret w1)) (NoItem w2) + | w1 > w2 = x + | otherwise = NamedItem name (FlexibleCaret w2) +pickHigher x@NamedItem{} _ = x +pickHigher x y = pickHigher y x addLabels :: Bool -> Set ExpectItem -> Set ExpectItem -> Set ExpectItem addLabels True !exs !exs' = Set.union exs exs' @@ -146,3 +190,27 @@ collectHintsErr exs width (Op op) = case op of updateWidth :: UMaybe Word -> Word -> UMaybe Word updateWidth UNothing !w = UJust w updateWidth (UJust w) w' = UJust (max w w') + +distinct :: forall a. Ord a => [a] -> [a] +distinct = go Set.empty + where + go :: Set a -> [a] -> [a] + go _ [] = [] + go seen (x:xs) + | Set.member x seen = go seen xs + | otherwise = x : go (Set.insert x seen) xs + +updateCaretWidth :: Bool -> CaretWidth -> Word -> (# Word, Bool #) +updateCaretWidth flexible cw !w + | isFlexible cw == flexible = (# max (width cw) w, flexible #) + | isFlexible cw = (# w, flexible #) + | otherwise = (# width cw, False #) + +adjustCaret :: Word -> DefuncError_ 'Vanilla -> Word +adjustCaret w (Base _ _ err) = max (unexpectedWidth err) w +adjustCaret w (Op op) = case op of + WithLabel err _ -> adjustCaret w err + WithHints err _ -> adjustCaret w err + WithReason err _ -> adjustCaret w err + Amended _ _ err -> adjustCaret w err + Merged err1 err2 -> adjustCaret (adjustCaret w err1) err2 From 475ae240b850d136bd88cdfab22357fe677ecb79 Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Sat, 27 Jan 2024 15:04:13 +0000 Subject: [PATCH 16/25] refactor(Internal): Factored the new ParseError out used in Builders --- gigaparsec.cabal | 1 + .../Internal/Errors/DefuncBuilders.hs | 8 +- .../Gigaparsec/Internal/Errors/ErrorItem.hs | 1 + .../Gigaparsec/Internal/Errors/ParseError.hs | 93 +++++++++++++++++++ 4 files changed, 99 insertions(+), 4 deletions(-) create mode 100644 src/Text/Gigaparsec/Internal/Errors/ParseError.hs diff --git a/gigaparsec.cabal b/gigaparsec.cabal index dda436bb..e3acbdfe 100644 --- a/gigaparsec.cabal +++ b/gigaparsec.cabal @@ -107,6 +107,7 @@ library Text.Gigaparsec.Internal.Errors.DefuncError, Text.Gigaparsec.Internal.Errors.DefuncTypes, Text.Gigaparsec.Internal.Errors.ErrorItem, + Text.Gigaparsec.Internal.Errors.ParseError, Text.Gigaparsec.Internal.RT, Text.Gigaparsec.Internal.Require, Text.Gigaparsec.Internal.Token.Generic, diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs index 1eb28f3c..1d8c39cb 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE GADTs, DataKinds, UnboxedTuples, UnboxedSums, PatternSynonyms, CPP #-} +{-# LANGUAGE GADTs, DataKinds, UnboxedTuples, PatternSynonyms, CPP #-} {-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_GHC -Wno-unused-imports #-} -- Yes, this is redundant, however, it is necessary to get the UNPACK to fire @@ -19,7 +19,7 @@ import Text.Gigaparsec.Internal.Errors.DefuncTypes ( ErrKind(Vanilla, Specialised), expecteds, unexpectedWidth ) -import Text.Gigaparsec.Internal.Errors (ParseError(VanillaError, SpecialisedError)) +import Text.Gigaparsec.Internal.Errors.ParseError (ParseError(VanillaError, SpecialisedError)) import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth(FlexibleCaret, width), isFlexible) import Text.Gigaparsec.Internal.Errors.DefuncError (isLexical) import Text.Gigaparsec.Internal.Errors.ErrorItem ( @@ -37,10 +37,10 @@ asParseError :: String -> DefuncError -> ParseError asParseError !input e@DefuncError{..} = case errKind of IsVanilla -> case makeVanilla 0 0 Set.empty (NoItem 0) Set.empty True errTy of (# line, col, exs, unex, reasons #) -> - VanillaError presentationOffset line col (toErrorItem input presentationOffset unex) exs reasons (isLexical e) 0 0 + VanillaError presentationOffset line col (toErrorItem input presentationOffset unex) exs reasons (isLexical e) IsSpecialised -> case makeSpec 0 0 0 True id errTy of (# line, col, width, _, dmsgs #) -> - SpecialisedError presentationOffset line col (distinct (dmsgs [])) (FlexibleCaret width) 0 0 + SpecialisedError presentationOffset line col (distinct (dmsgs [])) width where !outOfRange = presentationOffset < fromIntegral (length input) diff --git a/src/Text/Gigaparsec/Internal/Errors/ErrorItem.hs b/src/Text/Gigaparsec/Internal/Errors/ErrorItem.hs index de2997b3..ee1540f8 100644 --- a/src/Text/Gigaparsec/Internal/Errors/ErrorItem.hs +++ b/src/Text/Gigaparsec/Internal/Errors/ErrorItem.hs @@ -1,4 +1,5 @@ {-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK hide #-} -- Yes, this is redundant, however, it is necessary to get the UNPACK to fire on CaretWidth {-# OPTIONS_GHC -Wno-redundant-strictness-flags #-} module Text.Gigaparsec.Internal.Errors.ErrorItem ( diff --git a/src/Text/Gigaparsec/Internal/Errors/ParseError.hs b/src/Text/Gigaparsec/Internal/Errors/ParseError.hs new file mode 100644 index 00000000..8e41ebee --- /dev/null +++ b/src/Text/Gigaparsec/Internal/Errors/ParseError.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK hide #-} +{-# OPTIONS_GHC -Wno-partial-fields -Wno-missing-import-lists #-} +module Text.Gigaparsec.Internal.Errors.ParseError ( + module Text.Gigaparsec.Internal.Errors.ParseError + ) where + +import Prelude hiding (lines) + +import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty, (<|)) +import Data.Set qualified as Set (map, foldr) + +import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder, Token) +import Text.Gigaparsec.Errors.ErrorBuilder qualified as Builder (ErrorBuilder(..)) +import Text.Gigaparsec.Errors.ErrorBuilder qualified as Token (Token(..)) + +import Text.Gigaparsec.Internal.Errors.CaretControl +import Text.Gigaparsec.Internal.Errors.ErrorItem + +import Data.Set (Set) + +type ParseError :: * +data ParseError = VanillaError { presentationOffset :: {-# UNPACK #-} !Word + , line :: {-# UNPACK #-} !Word + , col :: {-# UNPACK #-} !Word + , unexpected :: !(Either Word UnexpectItem) + , expecteds :: !(Set ExpectItem) + , reasons :: !(Set String) + , lexicalError :: !Bool + } + | SpecialisedError { presentationOffset :: {-# UNPACK #-} !Word + , line :: {-# UNPACK #-} !Word + , col :: {-# UNPACK #-} !Word + , msgs :: ![String] + , caretWidth :: {-# UNPACK #-} !Span + } + +{-# INLINABLE fromParseError #-} +fromParseError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> ParseError -> err +fromParseError srcFile input err = + Builder.format (Builder.pos @err (line err) (col err)) (Builder.source @err srcFile) + (formatErr err) + where formatErr :: ParseError -> Builder.ErrorInfoLines err + formatErr VanillaError{..} = + Builder.vanillaError @err + (Builder.unexpected @err (either (const Nothing) (Just . fst) unexpectedTok)) + (Builder.expected @err (Builder.combineExpectedItems @err (Set.map expectItem expecteds))) + (Builder.combineMessages @err (Set.foldr (\r -> (Builder.reason @err r :)) [] reasons)) + (Builder.lineInfo @err curLine linesBefore linesAfter caret (trimToLine caretSize)) + where unexpectedTok = unexpectItem lexicalError <$> unexpected + caretSize = either id snd unexpectedTok + + formatErr SpecialisedError{..} = + Builder.specialisedError @err + (Builder.combineMessages @err (map (Builder.message @err) msgs)) + (Builder.lineInfo @err curLine linesBefore linesAfter caret (trimToLine caretWidth)) + + expectItem :: ExpectItem -> Builder.Item err + expectItem (ExpectRaw t) = Builder.raw @err t + expectItem (ExpectNamed n) = Builder.named @err n + expectItem ExpectEndOfInput = Builder.endOfInput @err + + unexpectItem :: Bool -> UnexpectItem -> (Builder.Item err, Span) + unexpectItem lexical (UnexpectRaw cs demanded) = + case Builder.unexpectedToken @err cs demanded lexical of + t@(Token.Raw tok) -> (Builder.raw @err tok, tokenSpan t) + Token.Named name w -> (Builder.named @err name, w) + unexpectItem _ (UnexpectNamed name caretWidth) = (Builder.named @err name, width caretWidth) + unexpectItem _ UnexpectEndOfInput = (Builder.endOfInput @err, 1) + + -- it is definitely the case that there are at least `line` lines + (allLinesBefore, curLine, allLinesAfter) = breakLines (line err - 1) (lines input) + linesBefore = drop (length allLinesBefore - Builder.numLinesBefore @err) allLinesBefore + linesAfter = take (Builder.numLinesAfter @err) allLinesAfter + + caret = col err - 1 + trimToLine width = min width (fromIntegral (length curLine) - caret + 1) + + lines :: String -> NonEmpty String + lines [] = "" :| [] + lines ('\n':cs) = "" <| lines cs + lines (c:cs) = let l :| ls = lines cs in (c:l) :| ls + + breakLines :: Word -> NonEmpty String -> ([String], String, [String]) + breakLines 0 (l :| ls) = ([], l, ls) + breakLines n (l :| ls) = case nonEmpty ls of + Nothing -> error "the focus line is guaranteed to exist" + Just ls' -> let (before, focus, after) = breakLines (n - 1) ls' + in (l : before, focus, after) + + tokenSpan :: Token -> Word + tokenSpan (Token.Raw cs) = fromIntegral (length cs) + tokenSpan (Token.Named _ w) = w From 1570ecd5f8b3709351f13ed5ede569be20baf927 Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Mon, 29 Jan 2024 14:40:27 +0000 Subject: [PATCH 17/25] refactor: make hint operations, allowing for substitution to defunc scheme --- src/Text/Gigaparsec/Errors/Combinator.hs | 8 ++++---- src/Text/Gigaparsec/Internal.hs | 15 +++++++-------- src/Text/Gigaparsec/Internal/Errors.hs | 15 +++++++++++++-- 3 files changed, 24 insertions(+), 14 deletions(-) diff --git a/src/Text/Gigaparsec/Errors/Combinator.hs b/src/Text/Gigaparsec/Errors/Combinator.hs index 93e0e6df..753db9d3 100644 --- a/src/Text/Gigaparsec/Errors/Combinator.hs +++ b/src/Text/Gigaparsec/Errors/Combinator.hs @@ -78,13 +78,13 @@ import Text.Gigaparsec.Errors.ErrorGen qualified as ErrorGen -- We want to use this to make the docs point to the right definition for users. import Text.Gigaparsec.Internal (Parsec) import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec), line, col, emptyErr, specialisedErr, raise, unexpectedErr, hints, consumed, useHints, adjustErr, hints, hintsValidOffset) -import Text.Gigaparsec.Internal.Errors (ParseError, CaretWidth(FlexibleCaret, RigidCaret), ExpectItem(ExpectNamed)) -import Text.Gigaparsec.Internal.Errors qualified as Internal (setLexical, amendErr, entrenchErr, dislodgeErr, partialAmendErr, labelErr, explainErr) +import Text.Gigaparsec.Internal.Errors (ParseError, CaretWidth(FlexibleCaret, RigidCaret)) +import Text.Gigaparsec.Internal.Errors qualified as Internal (setLexical, amendErr, entrenchErr, dislodgeErr, partialAmendErr, labelErr, explainErr, replaceHints) import Text.Gigaparsec.Internal.Require (require) import Text.Gigaparsec.Position (withWidth) import Data.Set (Set) -import Data.Set qualified as Set (empty, map) +import Data.Set qualified as Set (empty) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty (toList) import Data.Maybe (isNothing, fromJust) @@ -105,7 +105,7 @@ label ls (Internal.Parsec p) = let !origConsumed = Internal.consumed st good' x st' | Internal.consumed st' /= origConsumed = good x st' - | otherwise = good x st' { Internal.hints = Set.map ExpectNamed ls } + | otherwise = good x st' { Internal.hints = Internal.replaceHints ls } bad' err = Internal.useHints bad (Internal.labelErr origConsumed ls err) in p st good' bad' diff --git a/src/Text/Gigaparsec/Internal.hs b/src/Text/Gigaparsec/Internal.hs index 47e493cc..38e6feb7 100644 --- a/src/Text/Gigaparsec/Internal.hs +++ b/src/Text/Gigaparsec/Internal.hs @@ -18,17 +18,16 @@ own risk. module Text.Gigaparsec.Internal (module Text.Gigaparsec.Internal) where import Text.Gigaparsec.Internal.RT (RT) -import Text.Gigaparsec.Internal.Errors (ParseError, ExpectItem, CaretWidth) +import Text.Gigaparsec.Internal.Errors (ParseError, Hints, ExpectItem, CaretWidth) import Text.Gigaparsec.Internal.Errors qualified as Errors ( emptyErr, expectedErr, specialisedErr, mergeErr, unexpectedErr, - expecteds, isExpectedEmpty, presentationOffset, useHints + isExpectedEmpty, presentationOffset, useHints, emptyHints, addError ) import Control.Applicative (Applicative(liftA2), Alternative(empty, (<|>), many, some)) -- liftA2 required until 9.6 import Control.Selective (Selective(select)) import Data.Set (Set) -import Data.Set qualified as Set (empty, union) CPP_import_PortableUnlifted @@ -188,7 +187,7 @@ data State = State { -- | the valid for which hints can be used hintsValidOffset :: {-# UNPACK #-} !Word, -- | the hints at this point in time - hints :: !(Set ExpectItem), + hints :: !Hints, -- | Debug nesting debugLevel :: {-# UNPACK #-} !Int } @@ -199,7 +198,7 @@ emptyState !str = State { input = str , line = 1 , col = 1 , hintsValidOffset = 0 - , hints = Set.empty + , hints = Errors.emptyHints , debugLevel = 0 } @@ -219,14 +218,14 @@ errorToHints :: State -> ParseError -> State errorToHints st@State{..} err | consumed == Errors.presentationOffset err , not (Errors.isExpectedEmpty err) = - if hintsValidOffset < consumed then st { hints = Errors.expecteds err, hintsValidOffset = consumed } - else st { hints = Set.union hints (Errors.expecteds err) } + if hintsValidOffset < consumed then st { hints = Errors.addError Errors.emptyHints err, hintsValidOffset = consumed } + else st { hints = Errors.addError hints err } errorToHints st _ = st useHints :: (ParseError -> State -> RT r) -> (ParseError -> State -> RT r) useHints bad err st@State{hintsValidOffset, hints} | presentationOffset == hintsValidOffset = bad (Errors.useHints hints err) st - | otherwise = bad err st{ hintsValidOffset = presentationOffset, hints = Set.empty } + | otherwise = bad err st{ hintsValidOffset = presentationOffset, hints = Errors.emptyHints } where !presentationOffset = Errors.presentationOffset err adjustErr :: (ParseError -> ParseError) -> Parsec a -> Parsec a diff --git a/src/Text/Gigaparsec/Internal/Errors.hs b/src/Text/Gigaparsec/Internal/Errors.hs index 079b2555..c4052e0e 100644 --- a/src/Text/Gigaparsec/Internal/Errors.hs +++ b/src/Text/Gigaparsec/Internal/Errors.hs @@ -25,6 +25,17 @@ import Text.Gigaparsec.Internal.Errors.ErrorItem CPP_import_PortableUnlifted +newtype Hints = Hints (Set ExpectItem) + +emptyHints :: Hints +emptyHints = Hints Set.empty + +addError :: Hints -> ParseError -> Hints +addError !(Hints hints) err = Hints $ Set.union hints (expecteds err) + +replaceHints :: Set String -> Hints +replaceHints = Hints . Set.map ExpectNamed + type ParseError :: UnliftedDatatype data ParseError = VanillaError { presentationOffset :: {-# UNPACK #-} !Word , line :: {-# UNPACK #-} !Word @@ -146,8 +157,8 @@ setLexical :: ParseError -> ParseError setLexical err@VanillaError{} = err { lexicalError = True } setLexical err = err -useHints :: Set ExpectItem -> ParseError -> ParseError -useHints !hints err@VanillaError{expecteds} = err { expecteds = Set.union hints expecteds } +useHints :: Hints -> ParseError -> ParseError +useHints !(Hints hints) err@VanillaError{expecteds} = err { expecteds = Set.union hints expecteds } useHints _ err = err mergeErr :: ParseError -> ParseError -> ParseError From 50e8f6018c37e268f45b93099c512a42766669a3 Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Mon, 29 Jan 2024 14:57:19 +0000 Subject: [PATCH 18/25] feat(Internal): added DefuncHints --- gigaparsec.cabal | 1 + src/Text/Gigaparsec/Errors/Combinator.hs | 2 +- src/Text/Gigaparsec/Internal/Errors.hs | 8 +++-- .../Gigaparsec/Internal/Errors/DefuncHints.hs | 35 +++++++++++++++++++ 4 files changed, 42 insertions(+), 4 deletions(-) create mode 100644 src/Text/Gigaparsec/Internal/Errors/DefuncHints.hs diff --git a/gigaparsec.cabal b/gigaparsec.cabal index afe29ca2..3b2e39a0 100644 --- a/gigaparsec.cabal +++ b/gigaparsec.cabal @@ -105,6 +105,7 @@ library Text.Gigaparsec.Internal.Errors.CaretControl, Text.Gigaparsec.Internal.Errors.DefuncBuilders, Text.Gigaparsec.Internal.Errors.DefuncError, + Text.Gigaparsec.Internal.Errors.DefuncHints, Text.Gigaparsec.Internal.Errors.DefuncTypes, Text.Gigaparsec.Internal.Errors.ErrorItem, Text.Gigaparsec.Internal.Errors.ParseError, diff --git a/src/Text/Gigaparsec/Errors/Combinator.hs b/src/Text/Gigaparsec/Errors/Combinator.hs index 753db9d3..e8271c85 100644 --- a/src/Text/Gigaparsec/Errors/Combinator.hs +++ b/src/Text/Gigaparsec/Errors/Combinator.hs @@ -105,7 +105,7 @@ label ls (Internal.Parsec p) = let !origConsumed = Internal.consumed st good' x st' | Internal.consumed st' /= origConsumed = good x st' - | otherwise = good x st' { Internal.hints = Internal.replaceHints ls } + | otherwise = good x st' { Internal.hints = Internal.replaceHints ls (Internal.hints st') } bad' err = Internal.useHints bad (Internal.labelErr origConsumed ls err) in p st good' bad' diff --git a/src/Text/Gigaparsec/Internal/Errors.hs b/src/Text/Gigaparsec/Internal/Errors.hs index c4052e0e..6f2aaa0c 100644 --- a/src/Text/Gigaparsec/Internal/Errors.hs +++ b/src/Text/Gigaparsec/Internal/Errors.hs @@ -25,7 +25,7 @@ import Text.Gigaparsec.Internal.Errors.ErrorItem CPP_import_PortableUnlifted -newtype Hints = Hints (Set ExpectItem) +newtype Hints = Hints (Set ExpectItem) deriving (Show, Eq) emptyHints :: Hints emptyHints = Hints Set.empty @@ -33,8 +33,10 @@ emptyHints = Hints Set.empty addError :: Hints -> ParseError -> Hints addError !(Hints hints) err = Hints $ Set.union hints (expecteds err) -replaceHints :: Set String -> Hints -replaceHints = Hints . Set.map ExpectNamed +replaceHints :: Set String -> Hints -> Hints +replaceHints !ls (Hints exs) + | Set.null exs = emptyHints + | otherwise = Hints (Set.map ExpectNamed ls) type ParseError :: UnliftedDatatype data ParseError = VanillaError { presentationOffset :: {-# UNPACK #-} !Word diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncHints.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncHints.hs new file mode 100644 index 00000000..06e06fc7 --- /dev/null +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncHints.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE GADTs, NamedFieldPuns, BinaryLiterals, NumericUnderscores, DataKinds, BangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} +module Text.Gigaparsec.Internal.Errors.DefuncHints ( + DefuncHints, + empty, replace, addError, merge + ) where + +import Text.Gigaparsec.Internal.Errors.DefuncTypes ( + DefuncHints(Blank, Replace, Merge, AddErr), + DefuncError(DefuncError), ErrKindSingleton(IsVanilla) + ) + +import Data.Set (Set) + +{-# INLINE empty #-} +empty :: () -> DefuncHints +empty _ = Blank + +{-# INLINABLE replace #-} +replace :: Set String -> DefuncHints -> DefuncHints +replace !_ Blank = Blank +replace ls _ = Replace ls + +{-# INLINABLE addError #-} +addError :: DefuncHints -> DefuncError -> DefuncHints +addError hints (DefuncError IsVanilla _ _ _ err) = AddErr hints err +addError _ _ = error "invariance broken: a specialised error is never added to hints" + +{-# INLINABLE merge #-} +merge :: DefuncHints -> DefuncHints -> DefuncHints +merge Blank hs = hs +merge hs Blank = hs +merge hs1 hs2 = Merge hs1 hs2 From 8ab9069706d85887416beaa261a22ae8a3333d0a Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Mon, 29 Jan 2024 15:07:05 +0000 Subject: [PATCH 19/25] refactor(Internal): Added Error type for one final abstraction --- src/Text/Gigaparsec.hs | 6 ++-- src/Text/Gigaparsec/Char.hs | 4 +-- src/Text/Gigaparsec/Errors/Combinator.hs | 4 +-- src/Text/Gigaparsec/Errors/ErrorGen.hs | 8 +++--- src/Text/Gigaparsec/Internal.hs | 28 +++++++++---------- src/Text/Gigaparsec/Internal/Errors.hs | 19 +++++++------ .../Gigaparsec/Internal/Errors/ParseError.hs | 6 ++-- test/Text/Gigaparsec/DebugTests.hs | 2 +- 8 files changed, 40 insertions(+), 37 deletions(-) diff --git a/src/Text/Gigaparsec.hs b/src/Text/Gigaparsec.hs index 48db4a45..61a025f2 100644 --- a/src/Text/Gigaparsec.hs +++ b/src/Text/Gigaparsec.hs @@ -86,7 +86,7 @@ module Text.Gigaparsec ( import Text.Gigaparsec.Internal (Parsec(Parsec), emptyState, manyr, somer) import Text.Gigaparsec.Internal qualified as Internal (State(..), useHints, expectedErr) import Text.Gigaparsec.Internal.RT qualified as Internal (RT, runRT, rtToIO) -import Text.Gigaparsec.Internal.Errors qualified as Internal (ParseError, ExpectItem(ExpectEndOfInput), fromParseError) +import Text.Gigaparsec.Internal.Errors qualified as Internal (Error, ExpectItem(ExpectEndOfInput), fromError) import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder) import Text.Gigaparsec.Errors.Combinator (filterSWith, mapMaybeSWith) @@ -191,8 +191,8 @@ _parse :: forall err a. ErrorBuilder err => Maybe FilePath -> Parsec a -> String _parse file (Parsec p) inp = p (emptyState inp) good bad where good :: a -> Internal.State -> Internal.RT (Result err a) good x _ = return (Success x) - bad :: Internal.ParseError -> Internal.State -> Internal.RT (Result err a) - bad err _ = return (Failure (Internal.fromParseError file inp err)) + bad :: Internal.Error -> Internal.State -> Internal.RT (Result err a) + bad err _ = return (Failure (Internal.fromError file inp err)) {-| This combinator parses its argument @p@, but rolls back any consumed input on failure. diff --git a/src/Text/Gigaparsec/Char.hs b/src/Text/Gigaparsec/Char.hs index 29304082..1aafcd7f 100644 --- a/src/Text/Gigaparsec/Char.hs +++ b/src/Text/Gigaparsec/Char.hs @@ -50,7 +50,7 @@ import Text.Gigaparsec.Combinator (skipMany) import Text.Gigaparsec.Errors.Combinator (()) -- We want to use this to make the docs point to the right definition for users. import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec, unParsec), State(..), expectedErr, useHints) -import Text.Gigaparsec.Internal.Errors qualified as Internal (ExpectItem(ExpectRaw), ParseError) +import Text.Gigaparsec.Internal.Errors qualified as Internal (ExpectItem(ExpectRaw), Error) import Text.Gigaparsec.Internal.Require (require) import Data.Bits (Bits((.&.), (.|.))) @@ -168,7 +168,7 @@ string :: String -- ^ the string, @s@, to be parsed from the input string s = require (not (null s)) "Text.Gigaparsec.Char.string" "cannot pass empty string" $ --TODO: this could be much improved Internal.Parsec $ \st ok bad -> - let bad' (_ :: Internal.ParseError) = + let bad' (_ :: Internal.Error) = Internal.useHints bad (Internal.expectedErr st [Internal.ExpectRaw s] (fromIntegral (length s))) in Internal.unParsec (traverse char s) st ok bad' diff --git a/src/Text/Gigaparsec/Errors/Combinator.hs b/src/Text/Gigaparsec/Errors/Combinator.hs index e8271c85..2f198cd6 100644 --- a/src/Text/Gigaparsec/Errors/Combinator.hs +++ b/src/Text/Gigaparsec/Errors/Combinator.hs @@ -78,7 +78,7 @@ import Text.Gigaparsec.Errors.ErrorGen qualified as ErrorGen -- We want to use this to make the docs point to the right definition for users. import Text.Gigaparsec.Internal (Parsec) import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec), line, col, emptyErr, specialisedErr, raise, unexpectedErr, hints, consumed, useHints, adjustErr, hints, hintsValidOffset) -import Text.Gigaparsec.Internal.Errors (ParseError, CaretWidth(FlexibleCaret, RigidCaret)) +import Text.Gigaparsec.Internal.Errors (Error, CaretWidth(FlexibleCaret, RigidCaret)) import Text.Gigaparsec.Internal.Errors qualified as Internal (setLexical, amendErr, entrenchErr, dislodgeErr, partialAmendErr, labelErr, explainErr, replaceHints) import Text.Gigaparsec.Internal.Require (require) import Text.Gigaparsec.Position (withWidth) @@ -264,7 +264,7 @@ partialAmend :: Parsec a -> Parsec a partialAmend = _amend Internal.partialAmendErr {-# INLINE _amend #-} -_amend :: (Word -> Word -> Word -> ParseError -> ParseError) -> Parsec a -> Parsec a +_amend :: (Word -> Word -> Word -> Error -> Error) -> Parsec a -> Parsec a _amend f (Internal.Parsec p) = Internal.Parsec $ \st good bad -> let !origConsumed = Internal.consumed st diff --git a/src/Text/Gigaparsec/Errors/ErrorGen.hs b/src/Text/Gigaparsec/Errors/ErrorGen.hs index 0343cc0f..fc9af5fa 100644 --- a/src/Text/Gigaparsec/Errors/ErrorGen.hs +++ b/src/Text/Gigaparsec/Errors/ErrorGen.hs @@ -6,7 +6,7 @@ module Text.Gigaparsec.Errors.ErrorGen ( ) where import Text.Gigaparsec.Internal (Parsec) import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec), State, specialisedErr, emptyErr, expectedErr, unexpectedErr, raise) -import Text.Gigaparsec.Internal.Errors qualified as Internal (ParseError, CaretWidth(RigidCaret), addReason) +import Text.Gigaparsec.Internal.Errors qualified as Internal (Error, CaretWidth(RigidCaret), addReason) type ErrorGen :: * -> * data ErrorGen a = SpecializedGen { messages :: a -> [String] @@ -45,18 +45,18 @@ asSelect errGen (Internal.Parsec p) = Internal.Parsec $ \st good bad -> good' (Left (x, w)) st' = bad (genErr errGen st' x w) st' in p st good' bad -genErr :: ErrorGen a -> Internal.State -> a -> Word -> Internal.ParseError +genErr :: ErrorGen a -> Internal.State -> a -> Word -> Internal.Error genErr SpecializedGen{..} st x w = Internal.specialisedErr st (messages x) (Internal.RigidCaret (adjustWidth x w)) genErr VanillaGen{..} st x w = addReason (reason x) (makeError (unexpected x) st (adjustWidth x w)) -makeError :: UnexpectedItem -> Internal.State -> Word -> Internal.ParseError +makeError :: UnexpectedItem -> Internal.State -> Word -> Internal.Error makeError RawItem st cw = Internal.expectedErr st [] cw makeError EmptyItem st cw = Internal.emptyErr st cw makeError (NamedItem name) st cw = Internal.unexpectedErr st [] name (Internal.RigidCaret cw) -- no fold, unlifed type -addReason :: Maybe String -> Internal.ParseError -> Internal.ParseError +addReason :: Maybe String -> Internal.Error -> Internal.Error addReason Nothing err = err addReason (Just reason) err = Internal.addReason reason err diff --git a/src/Text/Gigaparsec/Internal.hs b/src/Text/Gigaparsec/Internal.hs index 38e6feb7..af985705 100644 --- a/src/Text/Gigaparsec/Internal.hs +++ b/src/Text/Gigaparsec/Internal.hs @@ -18,7 +18,7 @@ own risk. module Text.Gigaparsec.Internal (module Text.Gigaparsec.Internal) where import Text.Gigaparsec.Internal.RT (RT) -import Text.Gigaparsec.Internal.Errors (ParseError, Hints, ExpectItem, CaretWidth) +import Text.Gigaparsec.Internal.Errors (Error, Hints, ExpectItem, CaretWidth) import Text.Gigaparsec.Internal.Errors qualified as Errors ( emptyErr, expectedErr, specialisedErr, mergeErr, unexpectedErr, isExpectedEmpty, presentationOffset, useHints, emptyHints, addError @@ -56,8 +56,8 @@ libraries like @parsec@ and @gigaparsec@. type Parsec :: * -> * newtype Parsec a = Parsec { unParsec :: forall r. State - -> (a -> State -> RT r) -- the good continuation - -> (ParseError -> State -> RT r) -- the bad continuation + -> (a -> State -> RT r) -- the good continuation + -> (Error -> State -> RT r) -- the bad continuation -> RT r } @@ -125,7 +125,7 @@ instance Monad Parsec where {-# INLINE return #-} {-# INLINE (>>=) #-} -raise :: (State -> ParseError) -> Parsec a +raise :: (State -> Error) -> Parsec a raise mkErr = Parsec $ \st _ bad -> useHints bad (mkErr st) st instance Alternative Parsec where @@ -198,35 +198,35 @@ emptyState !str = State { input = str , line = 1 , col = 1 , hintsValidOffset = 0 - , hints = Errors.emptyHints + , hints = Errors.emptyHints () , debugLevel = 0 } -emptyErr :: State -> Word -> ParseError +emptyErr :: State -> Word -> Error emptyErr State{..} = Errors.emptyErr consumed line col -expectedErr :: State -> Set ExpectItem -> Word -> ParseError +expectedErr :: State -> Set ExpectItem -> Word -> Error expectedErr State{..} = Errors.expectedErr input consumed line col -specialisedErr :: State -> [String] -> CaretWidth -> ParseError +specialisedErr :: State -> [String] -> CaretWidth -> Error specialisedErr State{..} = Errors.specialisedErr consumed line col -unexpectedErr :: State -> Set ExpectItem -> String -> CaretWidth -> ParseError +unexpectedErr :: State -> Set ExpectItem -> String -> CaretWidth -> Error unexpectedErr State{..} = Errors.unexpectedErr consumed line col -errorToHints :: State -> ParseError -> State +errorToHints :: State -> Error -> State errorToHints st@State{..} err | consumed == Errors.presentationOffset err , not (Errors.isExpectedEmpty err) = - if hintsValidOffset < consumed then st { hints = Errors.addError Errors.emptyHints err, hintsValidOffset = consumed } + if hintsValidOffset < consumed then st { hints = Errors.addError (Errors.emptyHints ()) err, hintsValidOffset = consumed } else st { hints = Errors.addError hints err } errorToHints st _ = st -useHints :: (ParseError -> State -> RT r) -> (ParseError -> State -> RT r) +useHints :: (Error -> State -> RT r) -> (Error -> State -> RT r) useHints bad err st@State{hintsValidOffset, hints} | presentationOffset == hintsValidOffset = bad (Errors.useHints hints err) st - | otherwise = bad err st{ hintsValidOffset = presentationOffset, hints = Errors.emptyHints } + | otherwise = bad err st{ hintsValidOffset = presentationOffset, hints = Errors.emptyHints () } where !presentationOffset = Errors.presentationOffset err -adjustErr :: (ParseError -> ParseError) -> Parsec a -> Parsec a +adjustErr :: (Error -> Error) -> Parsec a -> Parsec a adjustErr f (Parsec p) = Parsec $ \st good bad -> p st good $ \err -> bad (f err) diff --git a/src/Text/Gigaparsec/Internal/Errors.hs b/src/Text/Gigaparsec/Internal/Errors.hs index 6f2aaa0c..31a57fdd 100644 --- a/src/Text/Gigaparsec/Internal/Errors.hs +++ b/src/Text/Gigaparsec/Internal/Errors.hs @@ -25,17 +25,20 @@ import Text.Gigaparsec.Internal.Errors.ErrorItem CPP_import_PortableUnlifted -newtype Hints = Hints (Set ExpectItem) deriving (Show, Eq) +type Error :: UnliftedDatatype +type Error = ParseError +type Hints :: * +newtype Hints = Hints (Set ExpectItem) deriving stock (Show, Eq) -emptyHints :: Hints -emptyHints = Hints Set.empty +emptyHints :: () -> Hints +emptyHints _ = Hints Set.empty addError :: Hints -> ParseError -> Hints addError !(Hints hints) err = Hints $ Set.union hints (expecteds err) replaceHints :: Set String -> Hints -> Hints replaceHints !ls (Hints exs) - | Set.null exs = emptyHints + | Set.null exs = emptyHints () | otherwise = Hints (Set.map ExpectNamed ls) type ParseError :: UnliftedDatatype @@ -214,12 +217,12 @@ isExpectedEmpty :: ParseError -> Bool isExpectedEmpty VanillaError{expecteds} = Set.null expecteds isExpectedEmpty _ = True -{-# INLINABLE fromParseError #-} -fromParseError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> ParseError -> err -fromParseError srcFile input err = +{-# INLINABLE fromError #-} +fromError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> Error -> err +fromError srcFile input err = Builder.format (Builder.pos @err (line err) (col err)) (Builder.source @err srcFile) (formatErr err) - where formatErr :: ParseError -> Builder.ErrorInfoLines err + where formatErr :: Error -> Builder.ErrorInfoLines err formatErr VanillaError{..} = Builder.vanillaError @err (Builder.unexpected @err (either (const Nothing) (Just . fst) unexpectedTok)) diff --git a/src/Text/Gigaparsec/Internal/Errors/ParseError.hs b/src/Text/Gigaparsec/Internal/Errors/ParseError.hs index 8e41ebee..eb75ca3c 100644 --- a/src/Text/Gigaparsec/Internal/Errors/ParseError.hs +++ b/src/Text/Gigaparsec/Internal/Errors/ParseError.hs @@ -35,9 +35,9 @@ data ParseError = VanillaError { presentationOffset :: {-# UNPACK #-} !Word , caretWidth :: {-# UNPACK #-} !Span } -{-# INLINABLE fromParseError #-} -fromParseError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> ParseError -> err -fromParseError srcFile input err = +{-# INLINABLE fromError #-} +fromError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> ParseError -> err +fromError srcFile input err = Builder.format (Builder.pos @err (line err) (col err)) (Builder.source @err srcFile) (formatErr err) where formatErr :: ParseError -> Builder.ErrorInfoLines err diff --git a/test/Text/Gigaparsec/DebugTests.hs b/test/Text/Gigaparsec/DebugTests.hs index 70853366..7abb1b5d 100644 --- a/test/Text/Gigaparsec/DebugTests.hs +++ b/test/Text/Gigaparsec/DebugTests.hs @@ -57,7 +57,7 @@ ioParse :: Parsec a -> String -> IO () ioParse (Internal.Parsec p) inp = Internal.rtToIO $ p (Internal.emptyState inp) good bad where good :: a -> Internal.State -> Internal.RT () good _ _ = return () - bad :: Internal.ParseError -> Internal.State -> Internal.RT () + bad :: Internal.Error -> Internal.State -> Internal.RT () bad _ _ = return () mockDebug :: String -> (DebugConfig -> Parsec a) -> IO String From 73b72d91b1915e1c925145b5fdf48b9398dfb7b2 Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Mon, 29 Jan 2024 16:18:02 +0000 Subject: [PATCH 20/25] switched to new system --- .github/workflows/ci.yaml | 6 +- src/Text/Gigaparsec/Errors/Combinator.hs | 3 +- src/Text/Gigaparsec/Internal.hs | 2 +- src/Text/Gigaparsec/Internal/Errors.hs | 292 ++++-------------- .../Internal/Errors/DefuncBuilders.hs | 2 +- .../Gigaparsec/Internal/Errors/DefuncError.hs | 6 +- .../Gigaparsec/Internal/Errors/ParseError.hs | 6 +- src/Text/Gigaparsec/Patterns.hs | 2 +- test/Text/Gigaparsec/ErrorsTests.hs | 9 +- test/Text/Gigaparsec/Internal/Test.hs | 4 +- 10 files changed, 74 insertions(+), 258 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 74346fc8..e5458bc2 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -16,11 +16,13 @@ jobs: # 26% 9.4 # 10% 9.6 # As such, we'll keep supporting 8.10 as an LTS of sorts for now. - ghc: ['8.10', '9.2', '9.4', latest] + ghc: ['8.10', '9.2', '9.4', '9.6', latest] cabal: ['3.6', latest] exclude: - ghc: '9.4' cabal: '3.6' + - ghc: '9.6' + cabal: '3.6' - ghc: 'latest' cabal: '3.6' env: @@ -30,7 +32,7 @@ jobs: uses: actions/checkout@v4 - name: Setup Haskell - uses: haskell/actions/setup@v2 + uses: haskell-actions/setup@v2 with: ghc-version: ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} diff --git a/src/Text/Gigaparsec/Errors/Combinator.hs b/src/Text/Gigaparsec/Errors/Combinator.hs index 2f198cd6..dbf80804 100644 --- a/src/Text/Gigaparsec/Errors/Combinator.hs +++ b/src/Text/Gigaparsec/Errors/Combinator.hs @@ -348,7 +348,8 @@ should be used to prevent @Lexer@-based token extraction from being performed on since lexing errors cannot be the result of unexpected tokens. -} markAsToken :: Parsec a -> Parsec a -markAsToken = Internal.adjustErr Internal.setLexical +markAsToken (Internal.Parsec p) = Internal.Parsec $ \st good bad -> + p st good $ \err -> bad (Internal.setLexical (Internal.consumed st) err) {-| This combinator changes the expected component of any errors generated by this parser. diff --git a/src/Text/Gigaparsec/Internal.hs b/src/Text/Gigaparsec/Internal.hs index af985705..1dbec835 100644 --- a/src/Text/Gigaparsec/Internal.hs +++ b/src/Text/Gigaparsec/Internal.hs @@ -187,7 +187,7 @@ data State = State { -- | the valid for which hints can be used hintsValidOffset :: {-# UNPACK #-} !Word, -- | the hints at this point in time - hints :: !Hints, + hints :: Hints, -- | Debug nesting debugLevel :: {-# UNPACK #-} !Int } diff --git a/src/Text/Gigaparsec/Internal/Errors.hs b/src/Text/Gigaparsec/Internal/Errors.hs index 31a57fdd..752e14c5 100644 --- a/src/Text/Gigaparsec/Internal/Errors.hs +++ b/src/Text/Gigaparsec/Internal/Errors.hs @@ -1,275 +1,89 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE RecordWildCards, BangPatterns, NamedFieldPuns, CPP #-} -{-# OPTIONS_GHC -Wno-partial-fields -Wno-all-missed-specialisations -Wno-missing-import-lists #-} +{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} {-# OPTIONS_HADDOCK hide #-} #include "portable-unlifted.h" --- Yes, this is redundant, however, it is necessary to get the UNPACK to fire on CaretWidth -{-# OPTIONS_GHC -Wno-redundant-strictness-flags #-} module Text.Gigaparsec.Internal.Errors ( module Text.Gigaparsec.Internal.Errors, - CaretWidth(..), ExpectItem(..) + CaretWidth(..), ExpectItem(..), + Error.presentationOffset, Error.isExpectedEmpty ) where -import Prelude hiding (lines) - -import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty, (<|)) import Data.Set (Set) -import Data.Set qualified as Set (empty, map, union, null, foldr, insert) -import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder, Token) -import Text.Gigaparsec.Errors.ErrorBuilder qualified as Builder (ErrorBuilder(..)) -import Text.Gigaparsec.Errors.ErrorBuilder qualified as Token (Token(..)) +import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder) + +import Text.Gigaparsec.Internal.Errors.DefuncError (DefuncError) +import Text.Gigaparsec.Internal.Errors.DefuncError qualified as Error +import Text.Gigaparsec.Internal.Errors.DefuncHints (DefuncHints) +import Text.Gigaparsec.Internal.Errors.DefuncHints qualified as Hints -import Text.Gigaparsec.Internal.Errors.CaretControl -import Text.Gigaparsec.Internal.Errors.ErrorItem +import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth(FlexibleCaret, RigidCaret)) +import Text.Gigaparsec.Internal.Errors.ErrorItem (ExpectItem(ExpectNamed, ExpectEndOfInput, ExpectRaw)) +import Text.Gigaparsec.Internal.Errors.ParseError (fromParseError) +import Text.Gigaparsec.Internal.Errors.DefuncBuilders (asParseError) CPP_import_PortableUnlifted type Error :: UnliftedDatatype -type Error = ParseError -type Hints :: * -newtype Hints = Hints (Set ExpectItem) deriving stock (Show, Eq) +type Error = DefuncError +type Hints :: UnliftedDatatype +type Hints = DefuncHints emptyHints :: () -> Hints -emptyHints _ = Hints Set.empty +emptyHints = Hints.empty -addError :: Hints -> ParseError -> Hints -addError !(Hints hints) err = Hints $ Set.union hints (expecteds err) +addError :: Hints -> Error -> Hints +addError = Hints.addError replaceHints :: Set String -> Hints -> Hints -replaceHints !ls (Hints exs) - | Set.null exs = emptyHints () - | otherwise = Hints (Set.map ExpectNamed ls) - -type ParseError :: UnliftedDatatype -data ParseError = VanillaError { presentationOffset :: {-# UNPACK #-} !Word - , line :: {-# UNPACK #-} !Word - , col :: {-# UNPACK #-} !Word - , unexpected :: !(Either Word UnexpectItem) -- TODO: unlift this! - -- sadly, this prevents unlifting of ExpectItem - -- perhaps we should make an unlifted+levity polymorphic Set? - , expecteds :: !(Set ExpectItem) - , reasons :: !(Set String) - , lexicalError :: !Bool -- TODO: strict bools - -- TODO: remove: - , underlyingOffset :: {-# UNPACK #-} !Word - , entrenchment :: {-# UNPACK #-} !Word - } - | SpecialisedError { presentationOffset :: {-# UNPACK #-} !Word - , line :: {-# UNPACK #-} !Word - , col :: {-# UNPACK #-} !Word - , msgs :: ![String] - --, caretWidth :: {-# UNPACK #-} !Span --FIXME: need defunc before this goes away - , caretWidth :: {-# UNPACK #-} !CaretWidth - -- TODO: remove: - , underlyingOffset :: {-# UNPACK #-} !Word - , entrenchment :: {-# UNPACK #-} !Word - } +replaceHints = Hints.replace -entrenched :: ParseError -> Bool -entrenched err = entrenchment err /= 0 +{-# INLINABLE fromError #-} +fromError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> Error -> err +fromError fp inp err = fromParseError fp inp (asParseError inp err) -emptyErr :: Word -> Word -> Word -> Word -> ParseError -emptyErr !presentationOffset !line !col !width = VanillaError { - presentationOffset = presentationOffset, - line = line, - col = col, - unexpected = Left width, - expecteds = Set.empty, - reasons = Set.empty, - lexicalError = False, - underlyingOffset = presentationOffset, - entrenchment = 0 - } +emptyErr :: Word -> Word -> Word -> Word -> Error +emptyErr = Error.emptyError -expectedErr :: String -> Word -> Word -> Word -> Set ExpectItem -> Word -> ParseError -expectedErr !input !presentationOffset !line !col !expecteds !width = VanillaError { - presentationOffset = presentationOffset, - line = line, - col = col, - unexpected = case nonEmpty input of - Nothing -> Right UnexpectEndOfInput - Just cs -> Right (UnexpectRaw cs width), - expecteds = expecteds, - reasons = Set.empty, - lexicalError = False, - underlyingOffset = presentationOffset, - entrenchment = 0 -} +expectedErr :: String -> Word -> Word -> Word -> Set ExpectItem -> Word -> Error +expectedErr _ = Error.expectedError -specialisedErr :: Word -> Word -> Word -> [String] -> CaretWidth -> ParseError -specialisedErr !presentationOffset !line !col !msgs caretWidth = SpecialisedError {..} - where !underlyingOffset = presentationOffset - !entrenchment = 0 :: Word +specialisedErr :: Word -> Word -> Word -> [String] -> CaretWidth -> Error +specialisedErr = Error.specialisedError -unexpectedErr :: Word -> Word -> Word -> Set ExpectItem -> String -> CaretWidth -> ParseError -unexpectedErr !presentationOffset !line !col !expecteds !name caretWidth = VanillaError { - presentationOffset = presentationOffset, - line = line, - col = col, - expecteds = expecteds, - unexpected = Right (UnexpectNamed name caretWidth), - reasons = Set.empty, - lexicalError = False, - underlyingOffset = presentationOffset, - entrenchment = 0 - } +unexpectedErr :: Word -> Word -> Word -> Set ExpectItem -> String -> CaretWidth -> Error +unexpectedErr = Error.unexpectedError -labelErr :: Word -> Set String -> ParseError -> ParseError -labelErr !offset expecteds err@VanillaError{} - | offset == presentationOffset err = err { expecteds = Set.map ExpectNamed expecteds } -labelErr _ _ err = err +labelErr :: Word -> Set String -> Error -> Error +labelErr = Error.label -explainErr :: Word -> String -> ParseError -> ParseError -explainErr !offset reason err@VanillaError{} - | offset == presentationOffset err = addReason reason err +--TODO: remove? +explainErr :: Word -> String -> Error -> Error +explainErr !offset reason err + | offset == Error.presentationOffset err = addReason reason err explainErr _ _ err = err -addReason :: String -> ParseError -> ParseError -addReason reason err@VanillaError{} = err { reasons = Set.insert reason (reasons err) } -addReason _ err = err - -amendErr :: Word -> Word -> Word -> ParseError -> ParseError -amendErr !offset !line !col err - | not (entrenched err) = err { - presentationOffset = offset, - underlyingOffset = offset, - line = line, - col = col - } -amendErr _ _ _ err = err - -partialAmendErr :: Word -> Word -> Word -> ParseError -> ParseError -partialAmendErr !offset !line !col err - | not (entrenched err) = err { - presentationOffset = offset, - line = line, - col = col - } -partialAmendErr _ _ _ err = err - -entrenchErr :: ParseError -> ParseError -entrenchErr err = err { entrenchment = entrenchment err + 1 } - -dislodgeErr :: Word -> ParseError -> ParseError -dislodgeErr by err - | entrenchment err == 0 = err - -- this case is important to avoid underflow on the unsigned Word - | by >= entrenchment err = err { entrenchment = 0 } - | otherwise = err { entrenchment = entrenchment err - by } - -setLexical :: ParseError -> ParseError -setLexical err@VanillaError{} = err { lexicalError = True } -setLexical err = err - -useHints :: Hints -> ParseError -> ParseError -useHints !(Hints hints) err@VanillaError{expecteds} = err { expecteds = Set.union hints expecteds } -useHints _ err = err - -mergeErr :: ParseError -> ParseError -> ParseError -mergeErr err1 err2 - | underlyingOffset err1 > underlyingOffset err2 = err1 - | underlyingOffset err1 < underlyingOffset err2 = err2 - | presentationOffset err1 > presentationOffset err2 = err1 - | presentationOffset err1 < presentationOffset err2 = err2 --- offsets are all equal, kinds must match -mergeErr err1@SpecialisedError{caretWidth} _err2@VanillaError{} - | isFlexible caretWidth = err1 -- TODO: flexible caret merging from err2 - | otherwise = err1 -mergeErr _err1@VanillaError{} err2@SpecialisedError{caretWidth} - | isFlexible caretWidth = err2 -- TODO: flexible caret merging from err1 - | otherwise = err2 -mergeErr err1@VanillaError{} err2@VanillaError{} = - err1 { unexpected = mergeUnexpect (unexpected err1) (unexpected err2) - , expecteds = Set.union (expecteds err1) (expecteds err2) - , reasons = Set.union (reasons err1) (reasons err2) - , lexicalError = lexicalError err1 || lexicalError err2 - } -mergeErr err1@SpecialisedError{} err2@SpecialisedError{} = - err1 { msgs = msgs err1 ++ msgs err2 - , caretWidth = mergeCaret (caretWidth err1) (caretWidth err2) - } - -mergeCaret :: CaretWidth -> CaretWidth -> CaretWidth -mergeCaret caret@RigidCaret{} FlexibleCaret{} = caret -mergeCaret FlexibleCaret{} caret@RigidCaret{} = caret -mergeCaret caret1 caret2 = caret1 { width = max (width caret1) (width caret2) } - -mergeUnexpect :: Either Word UnexpectItem -> Either Word UnexpectItem -> Either Word UnexpectItem -mergeUnexpect (Left w1) (Left w2) = Left (max w1 w2) --- TODO: widening can occur with flexible or raw tokens -mergeUnexpect Left{} w@Right{} = w -mergeUnexpect w@Right{} Left{} = w --- finally, two others will merge independently -mergeUnexpect (Right item1) (Right item2) = Right (mergeItem item1 item2) - where mergeItem UnexpectEndOfInput _ = UnexpectEndOfInput - mergeItem _ UnexpectEndOfInput = UnexpectEndOfInput - mergeItem it1@(UnexpectNamed _ cw1) it2@(UnexpectNamed _ cw2) - | isFlexible cw1, not (isFlexible cw2) = it2 - | not (isFlexible cw1), isFlexible cw2 = it1 - | width cw1 < width cw2 = it2 - | otherwise = it1 - mergeItem item@UnexpectNamed{} _ = item - mergeItem _ item@UnexpectNamed{} = item - mergeItem (UnexpectRaw cs w1) (UnexpectRaw _ w2) = UnexpectRaw cs (max w1 w2) - -isExpectedEmpty :: ParseError -> Bool -isExpectedEmpty VanillaError{expecteds} = Set.null expecteds -isExpectedEmpty _ = True - -{-# INLINABLE fromError #-} -fromError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> Error -> err -fromError srcFile input err = - Builder.format (Builder.pos @err (line err) (col err)) (Builder.source @err srcFile) - (formatErr err) - where formatErr :: Error -> Builder.ErrorInfoLines err - formatErr VanillaError{..} = - Builder.vanillaError @err - (Builder.unexpected @err (either (const Nothing) (Just . fst) unexpectedTok)) - (Builder.expected @err (Builder.combineExpectedItems @err (Set.map expectItem expecteds))) - (Builder.combineMessages @err (Set.foldr (\r -> (Builder.reason @err r :)) [] reasons)) - (Builder.lineInfo @err curLine linesBefore linesAfter caret (trimToLine caretSize)) - where unexpectedTok = unexpectItem lexicalError <$> unexpected - caretSize = either id snd unexpectedTok - - formatErr SpecialisedError{..} = - Builder.specialisedError @err - (Builder.combineMessages @err (map (Builder.message @err) msgs)) - (Builder.lineInfo @err curLine linesBefore linesAfter caret (trimToLine (width caretWidth))) +addReason :: String -> Error -> Error +addReason = Error.withReason - expectItem :: ExpectItem -> Builder.Item err - expectItem (ExpectRaw t) = Builder.raw @err t - expectItem (ExpectNamed n) = Builder.named @err n - expectItem ExpectEndOfInput = Builder.endOfInput @err +amendErr :: Word -> Word -> Word -> Error -> Error +amendErr = Error.amend False - unexpectItem :: Bool -> UnexpectItem -> (Builder.Item err, Span) - unexpectItem lexical (UnexpectRaw cs demanded) = - case Builder.unexpectedToken @err cs demanded lexical of - t@(Token.Raw tok) -> (Builder.raw @err tok, tokenSpan t) - Token.Named name w -> (Builder.named @err name, w) - unexpectItem _ (UnexpectNamed name caretWidth) = (Builder.named @err name, width caretWidth) - unexpectItem _ UnexpectEndOfInput = (Builder.endOfInput @err, 1) +partialAmendErr :: Word -> Word -> Word -> Error -> Error +partialAmendErr = Error.amend True - -- it is definitely the case that there are at least `line` lines - (allLinesBefore, curLine, allLinesAfter) = breakLines (line err - 1) (lines input) - linesBefore = drop (length allLinesBefore - Builder.numLinesBefore @err) allLinesBefore - linesAfter = take (Builder.numLinesAfter @err) allLinesAfter +entrenchErr :: Error -> Error +entrenchErr = Error.entrench - caret = col err - 1 - trimToLine width = min width (fromIntegral (length curLine) - caret + 1) +dislodgeErr :: Word -> Error -> Error +dislodgeErr !w = Error.dislodge (fromIntegral w) --FIXME: - lines :: String -> NonEmpty String - lines [] = "" :| [] - lines ('\n':cs) = "" <| lines cs - lines (c:cs) = let l :| ls = lines cs in (c:l) :| ls +setLexical :: Word -> Error -> Error +setLexical = Error.markAsLexical - breakLines :: Word -> NonEmpty String -> ([String], String, [String]) - breakLines 0 (l :| ls) = ([], l, ls) - breakLines n (l :| ls) = case nonEmpty ls of - Nothing -> error "the focus line is guaranteed to exist" - Just ls' -> let (before, focus, after) = breakLines (n - 1) ls' - in (l : before, focus, after) +useHints :: Hints -> Error -> Error +useHints = Error.withHints - tokenSpan :: Token -> Word - tokenSpan (Token.Raw cs) = fromIntegral (length cs) - tokenSpan (Token.Named _ w) = w +mergeErr :: Error -> Error -> Error +mergeErr = Error.merge diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs index 1d8c39cb..f61e5a51 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs @@ -42,7 +42,7 @@ asParseError !input e@DefuncError{..} = case errKind of (# line, col, width, _, dmsgs #) -> SpecialisedError presentationOffset line col (distinct (dmsgs [])) width where - !outOfRange = presentationOffset < fromIntegral (length input) + !outOfRange = presentationOffset >= fromIntegral (length input) makeVanilla :: Word -> Word -> Set ExpectItem -> BuilderUnexpectItem -> Set String -> Bool -> DefuncError_ 'Vanilla diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs index 223e5e59..9c39c76c 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs @@ -3,7 +3,7 @@ {-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_GHC -Wno-missing-import-lists #-} module Text.Gigaparsec.Internal.Errors.DefuncError ( - DefuncError, + DefuncError(presentationOffset), specialisedError, expectedError, unexpectedError, emptyError, merge, withHints, withReason, withReasonAndOffset, label, amend, entrench, dislodge, markAsLexical, @@ -116,8 +116,8 @@ withReasonAndOffset _ _ err = err withReason :: String -> DefuncError -> DefuncError withReason !reason err = withReasonAndOffset reason (presentationOffset err) err -label :: Set String -> Word -> DefuncError -> DefuncError -label !labels !off (DefuncError IsVanilla flags pOff uOff errTy) | pOff == off = +label :: Word -> Set String -> DefuncError -> DefuncError +label !off !labels (DefuncError IsVanilla flags pOff uOff errTy) | pOff == off = DefuncError IsVanilla flags' pOff uOff (Op (WithLabel errTy labels)) where !flags' | Set.null labels = setBit flags expectedEmptyBit diff --git a/src/Text/Gigaparsec/Internal/Errors/ParseError.hs b/src/Text/Gigaparsec/Internal/Errors/ParseError.hs index eb75ca3c..8e41ebee 100644 --- a/src/Text/Gigaparsec/Internal/Errors/ParseError.hs +++ b/src/Text/Gigaparsec/Internal/Errors/ParseError.hs @@ -35,9 +35,9 @@ data ParseError = VanillaError { presentationOffset :: {-# UNPACK #-} !Word , caretWidth :: {-# UNPACK #-} !Span } -{-# INLINABLE fromError #-} -fromError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> ParseError -> err -fromError srcFile input err = +{-# INLINABLE fromParseError #-} +fromParseError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> ParseError -> err +fromParseError srcFile input err = Builder.format (Builder.pos @err (line err) (col err)) (Builder.source @err srcFile) (formatErr err) where formatErr :: ParseError -> Builder.ErrorInfoLines err diff --git a/src/Text/Gigaparsec/Patterns.hs b/src/Text/Gigaparsec/Patterns.hs index a6c46be9..caaa12b2 100644 --- a/src/Text/Gigaparsec/Patterns.hs +++ b/src/Text/Gigaparsec/Patterns.hs @@ -102,7 +102,7 @@ splitFun' (AppT (AppT (AppT MulArrowT _) a) b) = a : splitFun' b -- linear funct splitFun' ty = [ty] -- When KindSignatures is off, the default (a :: *) that TH generates is broken! -#if __GLASGOW_HASKELL__ >= 902 +#if __GLASGOW_HASKELL__ >= 900 sanitiseStarT :: TyVarBndr flag -> TyVarBndr flag sanitiseStarT (KindedTV ty flag StarT) = PlainTV ty flag sanitiseStarT ty = ty diff --git a/test/Text/Gigaparsec/ErrorsTests.hs b/test/Text/Gigaparsec/ErrorsTests.hs index 9a1f4502..8be1e26e 100644 --- a/test/Text/Gigaparsec/ErrorsTests.hs +++ b/test/Text/Gigaparsec/ErrorsTests.hs @@ -101,7 +101,7 @@ emptyTests = testGroup "empty should" , testCase "produce an expected error under the influence of label in <|> chain" do testParse (char 'a' <|> label ["something, at least"] empty) "b" @?= Failure (TestError (1, 1) (VanillaError (Just (Raw "b")) [Raw "a", Named "something, at least"] [] 1)) - , expectFailBecause "no widening for carets in vanilla" $ testCase "have an effect if its caret is wider" do + , testCase "have an effect if its caret is wider" do testParse (char 'a' <|> emptyWide 3) "bcd" @?= Failure (TestError (1, 1) (VanillaError (Just (Raw "bcd")) [Raw "a"] [] 3)) ] @@ -127,7 +127,7 @@ failTests = testGroup "fail should" [ testCase "yield a raw message" do testParse @Int (fail ["hi"]) "b" @?= Failure (TestError (1, 1) (SpecialisedError ["hi"] 1)) - , expectFailBecause "no cross-error width merging" $ testCase "be flexible when the width is unspecified" do + , testCase "be flexible when the width is unspecified" do testParse (string "abc" <|> fail ["hi"]) "xyz" @?= Failure (TestError (1, 1) (SpecialisedError ["hi"] 3)) , testCase "dominate otherwise" do @@ -143,7 +143,7 @@ unexpectedTests = testGroup "unexpected should" , testCase "produce expected message under influence of label, along with original message" do testParse (char 'a' <|> label ["something less cute"] (unexpected "bee")) "b" @?= Failure (TestError (1, 1) (VanillaError (Just (Named "bee")) [Raw "a", Named "something less cute"] [] 1)) - , expectFailBecause "no widening for carets in vanilla" $ testCase "be flexible when the width is unspecified" do + , testCase "be flexible when the width is unspecified" do testParse (string "abc" <|> unexpected "bee") "xyz" @?= Failure (TestError (1, 1) (VanillaError (Just (Named "bee")) [Raw "abc"] [] 3)) , testCase "dominate otherwise" do @@ -389,8 +389,7 @@ regressionTests = testGroup "thou shalt not regress" err -> assertFailure $ "error message " ++ show err ++ " did not match" ] , testGroup "amend should" - -- FIXME: unclear why this would be the case - [ expectFail $ testCase "ensure that errors pick up a new unexpected token" do + [ testCase "ensure that errors pick up a new unexpected token" do let greeting = string "hello world" <* char '!' testParse (amend greeting ["greeting"]) "hello world." @?= Failure (TestError (1, 1) (VanillaError (Just (Raw "h")) [Named "greeting"] [] 1)) diff --git a/test/Text/Gigaparsec/Internal/Test.hs b/test/Text/Gigaparsec/Internal/Test.hs index 17281ed7..913648e6 100644 --- a/test/Text/Gigaparsec/Internal/Test.hs +++ b/test/Text/Gigaparsec/Internal/Test.hs @@ -130,6 +130,6 @@ instance Show LiftedState where . shows col . showString ", hintsValidOffset = " . shows hintsValidOffset - . showString ", hints = " - . shows hints + -- . showString ", hints = " + -- . shows hints . showChar '}' From 4343875bd90bcc6fb7d8e36e3438ab0ee95689ff Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Mon, 29 Jan 2024 16:34:11 +0000 Subject: [PATCH 21/25] fix(Internal): adjusted unpacks and fixed GHCi --- src/Text/Gigaparsec/Internal.hs | 8 +++---- src/Text/Gigaparsec/Internal/Errors.hs | 7 ++---- .../Gigaparsec/Internal/Errors/DefuncHints.hs | 8 ++----- .../Gigaparsec/Internal/Errors/DefuncTypes.hs | 24 ++++++++++--------- 4 files changed, 21 insertions(+), 26 deletions(-) diff --git a/src/Text/Gigaparsec/Internal.hs b/src/Text/Gigaparsec/Internal.hs index 1dbec835..dca57ceb 100644 --- a/src/Text/Gigaparsec/Internal.hs +++ b/src/Text/Gigaparsec/Internal.hs @@ -21,7 +21,7 @@ import Text.Gigaparsec.Internal.RT (RT) import Text.Gigaparsec.Internal.Errors (Error, Hints, ExpectItem, CaretWidth) import Text.Gigaparsec.Internal.Errors qualified as Errors ( emptyErr, expectedErr, specialisedErr, mergeErr, unexpectedErr, - isExpectedEmpty, presentationOffset, useHints, emptyHints, addError + isExpectedEmpty, presentationOffset, useHints, DefuncHints(Blank), addError ) import Control.Applicative (Applicative(liftA2), Alternative(empty, (<|>), many, some)) -- liftA2 required until 9.6 @@ -198,7 +198,7 @@ emptyState !str = State { input = str , line = 1 , col = 1 , hintsValidOffset = 0 - , hints = Errors.emptyHints () + , hints = Errors.Blank , debugLevel = 0 } @@ -218,14 +218,14 @@ errorToHints :: State -> Error -> State errorToHints st@State{..} err | consumed == Errors.presentationOffset err , not (Errors.isExpectedEmpty err) = - if hintsValidOffset < consumed then st { hints = Errors.addError (Errors.emptyHints ()) err, hintsValidOffset = consumed } + if hintsValidOffset < consumed then st { hints = Errors.addError (Errors.Blank) err, hintsValidOffset = consumed } else st { hints = Errors.addError hints err } errorToHints st _ = st useHints :: (Error -> State -> RT r) -> (Error -> State -> RT r) useHints bad err st@State{hintsValidOffset, hints} | presentationOffset == hintsValidOffset = bad (Errors.useHints hints err) st - | otherwise = bad err st{ hintsValidOffset = presentationOffset, hints = Errors.emptyHints () } + | otherwise = bad err st{ hintsValidOffset = presentationOffset, hints = Errors.Blank } where !presentationOffset = Errors.presentationOffset err adjustErr :: (Error -> Error) -> Parsec a -> Parsec a diff --git a/src/Text/Gigaparsec/Internal/Errors.hs b/src/Text/Gigaparsec/Internal/Errors.hs index 752e14c5..b67358cd 100644 --- a/src/Text/Gigaparsec/Internal/Errors.hs +++ b/src/Text/Gigaparsec/Internal/Errors.hs @@ -6,7 +6,7 @@ module Text.Gigaparsec.Internal.Errors ( module Text.Gigaparsec.Internal.Errors, CaretWidth(..), ExpectItem(..), - Error.presentationOffset, Error.isExpectedEmpty + Error.presentationOffset, Error.isExpectedEmpty, DefuncHints(Blank) ) where import Data.Set (Set) @@ -15,7 +15,7 @@ import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder) import Text.Gigaparsec.Internal.Errors.DefuncError (DefuncError) import Text.Gigaparsec.Internal.Errors.DefuncError qualified as Error -import Text.Gigaparsec.Internal.Errors.DefuncHints (DefuncHints) +import Text.Gigaparsec.Internal.Errors.DefuncHints (DefuncHints(Blank)) import Text.Gigaparsec.Internal.Errors.DefuncHints qualified as Hints import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth(FlexibleCaret, RigidCaret)) @@ -30,9 +30,6 @@ type Error = DefuncError type Hints :: UnliftedDatatype type Hints = DefuncHints -emptyHints :: () -> Hints -emptyHints = Hints.empty - addError :: Hints -> Error -> Hints addError = Hints.addError diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncHints.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncHints.hs index 06e06fc7..001b35a8 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncHints.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncHints.hs @@ -3,8 +3,8 @@ {-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_GHC -Wno-missing-import-lists #-} module Text.Gigaparsec.Internal.Errors.DefuncHints ( - DefuncHints, - empty, replace, addError, merge + DefuncHints(Blank), + replace, addError, merge ) where import Text.Gigaparsec.Internal.Errors.DefuncTypes ( @@ -14,10 +14,6 @@ import Text.Gigaparsec.Internal.Errors.DefuncTypes ( import Data.Set (Set) -{-# INLINE empty #-} -empty :: () -> DefuncHints -empty _ = Blank - {-# INLINABLE replace #-} replace :: Set String -> DefuncHints -> DefuncHints replace !_ Blank = Blank diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs index 74249998..a7a4d58f 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs @@ -20,20 +20,22 @@ CPP_import_PortableUnlifted type ErrKind :: * data ErrKind = Vanilla | Specialised -type ErrKindSingleton :: ErrKind -> UnliftedDatatype +-- Don't make this unlifted, it breaks GHC, unsure why +type ErrKindSingleton :: ErrKind -> * data ErrKindSingleton k where IsVanilla :: ErrKindSingleton 'Vanilla IsSpecialised :: ErrKindSingleton 'Specialised type DefuncError :: UnliftedDatatype data DefuncError = forall k. DefuncError { - errKind :: {-# UNPACK #-} !(ErrKindSingleton k), + errKind :: !(ErrKindSingleton k), flags :: {-# UNPACK #-} !Word32, presentationOffset :: {-# UNPACK #-} !Word, underlyingOffset :: {-# UNPACK #-} !Word, - errTy :: {-# UNPACK #-} !(DefuncError_ k) + errTy :: !(DefuncError_ k) } +-- We don't UNPACK this, reduces the allocations in other parts type DefuncError_ :: ErrKind -> UnliftedDatatype data DefuncError_ k where Base :: {-# UNPACK #-} !Word -- ^ line @@ -65,20 +67,20 @@ unexpectedWidth (Empty w) = w type ErrorOp :: ErrKind -> UnliftedDatatype data ErrorOp k where - Merged :: {-# UNPACK #-} !(DefuncError_ k) -> {-# UNPACK #-} !(DefuncError_ k) -> ErrorOp k - AdjustCaret :: {-# UNPACK #-} !(DefuncError_ 'Specialised) - -> {-# UNPACK #-} !(DefuncError_ 'Vanilla) -- ^ caretAdjuster + Merged :: !(DefuncError_ k) -> !(DefuncError_ k) -> ErrorOp k + AdjustCaret :: !(DefuncError_ 'Specialised) + -> !(DefuncError_ 'Vanilla) -- ^ caretAdjuster -> ErrorOp 'Specialised - WithHints :: {-# UNPACK #-} !(DefuncError_ 'Vanilla) -> !DefuncHints -> ErrorOp 'Vanilla - WithReason :: {-# UNPACK #-} !(DefuncError_ 'Vanilla) -> !String -> ErrorOp 'Vanilla - WithLabel :: {-# UNPACK #-} !(DefuncError_ 'Vanilla) -> !(Set String) -> ErrorOp 'Vanilla + WithHints :: !(DefuncError_ 'Vanilla) -> !DefuncHints -> ErrorOp 'Vanilla + WithReason :: !(DefuncError_ 'Vanilla) -> !String -> ErrorOp 'Vanilla + WithLabel :: !(DefuncError_ 'Vanilla) -> !(Set String) -> ErrorOp 'Vanilla Amended :: {-# UNPACK #-} !Word -- ^ line -> {-# UNPACK #-} !Word -- ^ col - -> {-# UNPACK #-} !(DefuncError_ k) -> ErrorOp k + -> !(DefuncError_ k) -> ErrorOp k type DefuncHints :: UnliftedDatatype data DefuncHints where Blank :: DefuncHints Replace :: !(Set String) -> DefuncHints Merge :: !DefuncHints -> !DefuncHints -> DefuncHints - AddErr :: !DefuncHints -> {-# UNPACK #-} !(DefuncError_ 'Vanilla) -> DefuncHints + AddErr :: !DefuncHints -> !(DefuncError_ 'Vanilla) -> DefuncHints From 9a6d661b07c63e86a00c323aad309fb29d5c3bdb Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Mon, 29 Jan 2024 16:36:34 +0000 Subject: [PATCH 22/25] Weakened bounds on bytestring --- gigaparsec.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gigaparsec.cabal b/gigaparsec.cabal index 3b2e39a0..686b262b 100644 --- a/gigaparsec.cabal +++ b/gigaparsec.cabal @@ -180,7 +180,7 @@ test-suite gigaparsec-test gigaparsec, containers >= 0.6 && < 0.7, deepseq >= 1.4 && < 1.6, - bytestring >= 0.10 && < 0.12, + bytestring >= 0.10 && < 0.13, --deriving-compat >= 0.6 && < 0.7, tasty >=1.1 && <1.6, tasty-expected-failure >=0.11 && <0.13, From 77c55d65eb693fe8040b838288c9f8f139eb8ae9 Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Mon, 29 Jan 2024 16:49:53 +0000 Subject: [PATCH 23/25] refactor: removed unused code --- gigaparsec.cabal | 2 +- src/Text/Gigaparsec/Internal/Errors.hs | 16 ++++++++++++++++ .../Gigaparsec/Internal/Errors/DefuncBuilders.hs | 5 +---- .../Gigaparsec/Internal/Errors/DefuncHints.hs | 10 ++-------- .../Gigaparsec/Internal/Errors/DefuncTypes.hs | 1 - 5 files changed, 20 insertions(+), 14 deletions(-) diff --git a/gigaparsec.cabal b/gigaparsec.cabal index 686b262b..156f7629 100644 --- a/gigaparsec.cabal +++ b/gigaparsec.cabal @@ -180,7 +180,7 @@ test-suite gigaparsec-test gigaparsec, containers >= 0.6 && < 0.7, deepseq >= 1.4 && < 1.6, - bytestring >= 0.10 && < 0.13, + bytestring >= 0.9 && < 0.13, --deriving-compat >= 0.6 && < 0.7, tasty >=1.1 && <1.6, tasty-expected-failure >=0.11 && <0.13, diff --git a/src/Text/Gigaparsec/Internal/Errors.hs b/src/Text/Gigaparsec/Internal/Errors.hs index b67358cd..b3036511 100644 --- a/src/Text/Gigaparsec/Internal/Errors.hs +++ b/src/Text/Gigaparsec/Internal/Errors.hs @@ -30,9 +30,11 @@ type Error = DefuncError type Hints :: UnliftedDatatype type Hints = DefuncHints +{-# INLINE addError #-} addError :: Hints -> Error -> Hints addError = Hints.addError +{-# INLINE replaceHints #-} replaceHints :: Set String -> Hints -> Hints replaceHints = Hints.replace @@ -40,47 +42,61 @@ replaceHints = Hints.replace fromError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> Error -> err fromError fp inp err = fromParseError fp inp (asParseError inp err) +{-# INLINE emptyErr #-} emptyErr :: Word -> Word -> Word -> Word -> Error emptyErr = Error.emptyError +{-# INLINE expectedErr #-} expectedErr :: String -> Word -> Word -> Word -> Set ExpectItem -> Word -> Error expectedErr _ = Error.expectedError +{-# INLINE specialisedErr #-} specialisedErr :: Word -> Word -> Word -> [String] -> CaretWidth -> Error specialisedErr = Error.specialisedError +{-# INLINE unexpectedErr #-} unexpectedErr :: Word -> Word -> Word -> Set ExpectItem -> String -> CaretWidth -> Error unexpectedErr = Error.unexpectedError +{-# INLINE labelErr #-} labelErr :: Word -> Set String -> Error -> Error labelErr = Error.label --TODO: remove? +{-# INLINABLE explainErr #-} explainErr :: Word -> String -> Error -> Error explainErr !offset reason err | offset == Error.presentationOffset err = addReason reason err explainErr _ _ err = err +{-# INLINE addReason #-} addReason :: String -> Error -> Error addReason = Error.withReason +{-# INLINE amendErr #-} amendErr :: Word -> Word -> Word -> Error -> Error amendErr = Error.amend False +{-# INLINE partialAmendErr #-} partialAmendErr :: Word -> Word -> Word -> Error -> Error partialAmendErr = Error.amend True +{-# INLINE entrenchErr #-} entrenchErr :: Error -> Error entrenchErr = Error.entrench +{-# INLINE dislodgeErr #-} dislodgeErr :: Word -> Error -> Error dislodgeErr !w = Error.dislodge (fromIntegral w) --FIXME: +{-# INLINE setLexical #-} setLexical :: Word -> Error -> Error setLexical = Error.markAsLexical +{-# INLINE useHints #-} useHints :: Hints -> Error -> Error useHints = Error.withHints +{-# INLINE mergeErr #-} mergeErr :: Error -> Error -> Error mergeErr = Error.merge diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs index f61e5a51..619bf34f 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs @@ -10,7 +10,7 @@ module Text.Gigaparsec.Internal.Errors.DefuncBuilders ( ) where import Text.Gigaparsec.Internal.Errors.DefuncTypes ( - DefuncHints(Blank, Merge, AddErr, Replace), + DefuncHints(Blank, AddErr, Replace), ErrorOp(Amended, WithLabel, WithHints, Merged, WithReason, AdjustCaret), BaseError(Unexpected, Empty, Expected, ClassicSpecialised), DefuncError_(Op, Base), @@ -165,9 +165,6 @@ pattern UNothing = (# (# #) | #) collectHints :: Set ExpectItem -> UMaybe Word -> DefuncHints -> (# Set ExpectItem, UMaybe Word #) collectHints !exs width Blank = (# exs, width #) collectHints exs width (Replace ls) = (# Set.union exs (Set.map ExpectNamed ls), width #) -collectHints exs width (Merge hints1 hints2) = - let !(# exs', width' #) = collectHints exs width hints1 - in collectHints exs' width' hints2 collectHints exs width (AddErr hints err) = let !(# exs', width' #) = collectHintsErr exs width err in collectHints exs' width' hints diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncHints.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncHints.hs index 001b35a8..9227e8ad 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncHints.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncHints.hs @@ -4,11 +4,11 @@ {-# OPTIONS_GHC -Wno-missing-import-lists #-} module Text.Gigaparsec.Internal.Errors.DefuncHints ( DefuncHints(Blank), - replace, addError, merge + replace, addError ) where import Text.Gigaparsec.Internal.Errors.DefuncTypes ( - DefuncHints(Blank, Replace, Merge, AddErr), + DefuncHints(Blank, Replace, AddErr), DefuncError(DefuncError), ErrKindSingleton(IsVanilla) ) @@ -23,9 +23,3 @@ replace ls _ = Replace ls addError :: DefuncHints -> DefuncError -> DefuncHints addError hints (DefuncError IsVanilla _ _ _ err) = AddErr hints err addError _ _ = error "invariance broken: a specialised error is never added to hints" - -{-# INLINABLE merge #-} -merge :: DefuncHints -> DefuncHints -> DefuncHints -merge Blank hs = hs -merge hs Blank = hs -merge hs1 hs2 = Merge hs1 hs2 diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs index a7a4d58f..725841c9 100644 --- a/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs @@ -82,5 +82,4 @@ type DefuncHints :: UnliftedDatatype data DefuncHints where Blank :: DefuncHints Replace :: !(Set String) -> DefuncHints - Merge :: !DefuncHints -> !DefuncHints -> DefuncHints AddErr :: !DefuncHints -> !(DefuncError_ 'Vanilla) -> DefuncHints From 97431fbd3af6b1afb478b606e2dced9639f984ee Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Mon, 29 Jan 2024 17:10:29 +0000 Subject: [PATCH 24/25] ci: fix cabal freeze generation --- .github/workflows/ci.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index e5458bc2..6bec68b7 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -40,7 +40,7 @@ jobs: - name: Determine Dependencies run: | cabal update - cabal freeze + cabal freeze $CONFIG - name: Check Cache uses: actions/cache@v2 @@ -84,7 +84,7 @@ jobs: - name: Determine Dependencies run: | cabal update - cabal freeze + cabal freeze $CONFIG - name: Check Cache uses: actions/cache@v2 From 1378609e3617b983ce21e636da927793e141f0fb Mon Sep 17 00:00:00 2001 From: Jamie Willis Date: Mon, 29 Jan 2024 17:14:55 +0000 Subject: [PATCH 25/25] changelog and version bump --- CHANGELOG.md | 8 ++++++-- gigaparsec.cabal | 2 +- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7d736443..08082c2f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,11 @@ # Revision history for gigaparsec -## 0.2.2.1 -- 2014-01-29 -* Fixed bug where case sensitive keywords where parsed insensitively and vice-versa +## 0.2.2.2 -- 2024-01-29 +* Optimised the error system using `DefuncError` and `DefuncHints`. +* Fixed bugs with amending and token merging. + +## 0.2.2.1 -- 2024-01-29 +* Fixed bug where case sensitive keywords where parsed insensitively and vice-versa. ## 0.2.2.0 -- 2024-01-21 diff --git a/gigaparsec.cabal b/gigaparsec.cabal index 156f7629..281d0da6 100644 --- a/gigaparsec.cabal +++ b/gigaparsec.cabal @@ -20,7 +20,7 @@ name: gigaparsec -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.2.1 +version: 0.2.2.2 -- A short (one-line) description of the package. synopsis: