Skip to content

Commit 482f476

Browse files
dtpowldtpowl
committed
PR feedback
1 parent 4d8cedd commit 482f476

7 files changed

Lines changed: 76 additions & 68 deletions

File tree

‎persistent/Database/Persist/Quasi/Internal.hs‎

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -13,8 +13,6 @@
1313
-- @since 2.13.0.0
1414
module Database.Persist.Quasi.Internal
1515
( parse
16-
, ParserWarning
17-
, parserWarningMessage
1816
, PersistSettings (..)
1917
, upperCaseSettings
2018
, lowerCaseSettings
@@ -26,7 +24,7 @@ module Database.Persist.Quasi.Internal
2624
, takeColsEx
2725
, CumulativeParseResult (..)
2826
, renderErrors
29-
, renderWarnings
27+
, parserWarningMessage
3028

3129
-- * UnboundEntityDef
3230
, UnboundEntityDef (..)

‎persistent/Database/Persist/Quasi/Internal/ModelParser.hs‎

Lines changed: 22 additions & 60 deletions
Original file line numberDiff line numberDiff line change
@@ -29,7 +29,6 @@ module Database.Persist.Quasi.Internal.ModelParser
2929
, CumulativeParseResult
3030
, toCumulativeParseResult
3131
, renderErrors
32-
, renderWarnings
3332
, runConfiguredParser
3433
, ParserErrorLevel (..)
3534
, initialExtraState
@@ -62,37 +61,7 @@ import Text.Megaparsec.Char
6261
import qualified Text.Megaparsec.Char.Lexer as L
6362
import qualified Text.Megaparsec.Stream as TMS
6463

65-
-- @since 2.16.0.0
66-
data ParserErrorLevel = LevelError | LevelWarning deriving (Eq, Show)
67-
68-
-- @since 2.16.0.0
69-
newtype ParserSettings = ParserSettings {parserTabErrorLevel :: Maybe ParserErrorLevel}
70-
71-
-- @since 2.16.0.0
72-
defaultParserSettings :: ParserSettings
73-
defaultParserSettings = ParserSettings{parserTabErrorLevel = Just LevelWarning}
74-
75-
-- @since 2.16.0.0
76-
data ParserWarning = ParserWarning
77-
{ parserWarningExtraMessage :: String
78-
, parserWarningUnderlyingError :: ParseError String Void
79-
, parserWarningPosState :: PosState String
80-
}
81-
deriving (Eq, Show)
82-
83-
instance Ord ParserWarning where
84-
l <= r = parserWarningMessage l <= parserWarningMessage r
85-
86-
-- @since 2.16.0.0
87-
parserWarningMessage :: ParserWarning -> String
88-
parserWarningMessage pw =
89-
parserWarningExtraMessage pw
90-
<> ( errorBundlePretty $
91-
ParseErrorBundle
92-
{ bundleErrors = parserWarningUnderlyingError pw :| []
93-
, bundlePosState = parserWarningPosState pw
94-
}
95-
)
64+
import Database.Persist.Quasi.ParserSettings.Internal
9665

9766
-- We'll augment the parser with extra state to accumulate comments seen during parsing.
9867
-- Comments are lexed as whitespace, but will be used to generate documentation later.
@@ -120,7 +89,7 @@ newtype Parser a = Parser
12089
Void
12190
String
12291
( Writer
123-
[ParserWarning]
92+
(Set ParserWarning)
12493
)
12594
)
12695
)
@@ -135,7 +104,7 @@ newtype Parser a = Parser
135104
, MonadState ExtraState
136105
, MonadReader ParserSettings
137106
, MonadParsec Void String
138-
, MonadWriter [ParserWarning]
107+
, MonadWriter (Set ParserWarning)
139108
)
140109

141110
type EntityParseError = ParseErrorBundle String Void
@@ -180,7 +149,7 @@ runConfiguredParser ps acc parser fp s = (filteredWarnings, either)
180149
-- For example, if two parsers which depend on the same subparser both attempt to
181150
-- parse the same span of input, any warnings generated by that subparser will be
182151
-- registered twice.
183-
filteredWarnings = Set.toList $ Set.fromList warnings
152+
filteredWarnings = Set.toList warnings
184153

185154
initialSourcePos =
186155
SourcePos
@@ -211,13 +180,7 @@ runConfiguredParser ps acc parser fp s = (filteredWarnings, either)
211180
renderErrors :: [EntityParseError] -> String
212181
renderErrors errs = intercalate "\n" $ fmap errorBundlePretty errs
213182

214-
-- | Renders a list of ParserWarnings as a String,
215-
-- separated by line breaks.
216-
-- @since 2.16.0.0
217-
renderWarnings :: [ParserWarning] -> String
218-
renderWarnings warnings = intercalate "\n" $ fmap parserWarningMessage warnings
219-
220-
-- Attempts to parse with a provided parser. If it fails with an error matching
183+
-- | Attempts to parse with a provided parser. If it fails with an error matching
221184
-- the provided predicate, it registers a warning with the provided message and falls
222185
-- back to the second provided parser.
223186
tryOrWarn
@@ -226,29 +189,28 @@ tryOrWarn
226189
-> Parser a
227190
-> Parser a
228191
-> Parser a
229-
tryOrWarn msg f l r = do
192+
tryOrWarn msg p l r = do
230193
parserState <- getParserState
231194
withRecovery (warnAndRetry $ statePosState parserState) l
232195
where
233196
warnAndRetry posState err = do
234-
if f err
197+
if p err
235198
then do
236199
let
237200
(pairs, _) = attachSourcePos errorOffset [err] posState
238-
tell $
239-
map
240-
( \(e, _pos) ->
241-
ParserWarning
242-
{ parserWarningExtraMessage = msg <> "\n"
243-
, parserWarningUnderlyingError = e
244-
, parserWarningPosState = posState
245-
}
246-
)
247-
pairs
201+
tell . Set.fromList $
202+
map ( \(e, _pos) ->
203+
ParserWarning
204+
{ parserWarningExtraMessage = msg <> "\n"
205+
, parserWarningUnderlyingError = e
206+
, parserWarningPosState = posState
207+
}
208+
)
209+
pairs
248210
r
249211
else parseError err
250212

251-
-- Attempts to parse with a provided parser. If it fails with an error matching
213+
-- | Attempts to parse with a provided parser. If it fails with an error matching
252214
-- the provided predicate, it registers a delayed error with the provided message and falls
253215
-- back to the second provided parser.
254216
--
@@ -261,12 +223,12 @@ tryOrRegisterError
261223
-> Parser a
262224
-> Parser a
263225
-> Parser a
264-
tryOrRegisterError msg f l r = do
226+
tryOrRegisterError msg p l r = do
265227
parserState <- getParserState
266228
withRecovery (delayedError $ statePosState parserState) l
267229
where
268230
delayedError posState err = do
269-
if f err
231+
if p err
270232
then do
271233
let
272234
(pairs, _) = attachSourcePos errorOffset [err] posState
@@ -281,9 +243,9 @@ tryOrReport
281243
-> Parser a
282244
-> Parser a
283245
-> Parser a
284-
tryOrReport level msg f l r = case level of
285-
Just LevelError -> tryOrRegisterError msg f l r
286-
Just LevelWarning -> tryOrWarn msg f l r
246+
tryOrReport level msg p l r = case level of
247+
Just LevelError -> tryOrRegisterError msg p l r
248+
Just LevelWarning -> tryOrWarn msg p l r
287249
Nothing -> r
288250

289251
-- | Source location: file and line/col information. This is half of a 'SourceSpan'.

‎persistent/Database/Persist/Quasi/ParserSettings.hs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
module Database.Persist.Quasi.ParserSettings
2+
( ParserSettings (..)
3+
, ParserWarning
4+
, ParserErrorLevel (..)
5+
, parserWarningMessage
6+
) where
7+
8+
import Database.Persist.Quasi.ParserSettings.Internal

‎persistent/Database/Persist/Quasi/ParserSettings/Internal.hs‎

Lines changed: 41 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,41 @@
1+
module Database.Persist.Quasi.ParserSettings.Internal where
2+
3+
import Data.Void (Void)
4+
import Text.Megaparsec ( ParseError
5+
, PosState
6+
, ParseErrorBundle (..)
7+
, errorBundlePretty
8+
)
9+
import Data.List.NonEmpty (NonEmpty (..))
10+
11+
-- @since 2.16.0.0
12+
data ParserErrorLevel = LevelError | LevelWarning deriving (Eq, Show)
13+
14+
-- @since 2.16.0.0
15+
newtype ParserSettings = ParserSettings {parserTabErrorLevel :: Maybe ParserErrorLevel}
16+
17+
-- @since 2.16.0.0
18+
defaultParserSettings :: ParserSettings
19+
defaultParserSettings = ParserSettings{parserTabErrorLevel = Just LevelWarning}
20+
21+
-- @since 2.16.0.0
22+
data ParserWarning = ParserWarning
23+
{ parserWarningExtraMessage :: String
24+
, parserWarningUnderlyingError :: ParseError String Void
25+
, parserWarningPosState :: PosState String
26+
}
27+
deriving (Eq, Show)
28+
29+
instance Ord ParserWarning where
30+
l <= r = parserWarningMessage l <= parserWarningMessage r
31+
32+
-- @since 2.16.0.0
33+
parserWarningMessage :: ParserWarning -> String
34+
parserWarningMessage pw =
35+
parserWarningExtraMessage pw
36+
<> ( errorBundlePretty $
37+
ParseErrorBundle
38+
{ bundleErrors = parserWarningUnderlyingError pw :| []
39+
, bundlePosState = parserWarningPosState pw
40+
}
41+
)

‎persistent/Database/Persist/TH/Internal.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -284,7 +284,7 @@ embedEntityDefsMap existingEnts rawEnts =
284284
parseReferences :: PersistSettings -> [(Maybe SourceLoc, Text)] -> Q Exp
285285
parseReferences ps s = do
286286
let (warnings, res) = parse ps s
287-
_ <- reportWarning $ renderWarnings warnings
287+
_ <- traverse (reportWarning . parserWarningMessage) warnings
288288
case res of
289289
Left errs -> fail $ renderErrors errs
290290
Right res -> lift res

‎persistent/persistent.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -82,6 +82,8 @@ library
8282
Database.Persist.Quasi
8383
Database.Persist.Quasi.Internal
8484
Database.Persist.Quasi.Internal.ModelParser
85+
Database.Persist.Quasi.ParserSettings
86+
Database.Persist.Quasi.ParserSettings.Internal
8587
Database.Persist.Sql
8688
Database.Persist.Sql.Migration
8789
Database.Persist.Sql.Types.Internal

‎persistent/test/Database/Persist/QuasiSpec.hs‎

Lines changed: 1 addition & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ import qualified Data.Map as Map
1616
import qualified Data.Text as T
1717
import Database.Persist.EntityDef.Internal
1818
import Database.Persist.Quasi
19+
import Database.Persist.Quasi.ParserSettings
1920
import Database.Persist.Quasi.Internal
2021
import Database.Persist.Quasi.Internal.ModelParser
2122
import Database.Persist.Types
@@ -25,10 +26,6 @@ import Test.QuickCheck
2526
import Text.Shakespeare.Text (st)
2627
import Text.Megaparsec (errorBundlePretty, runParser, some)
2728

28-
import Database.Persist.Quasi.Internal
29-
import Database.Persist.Quasi.Internal.ModelParser
30-
import Text.Megaparsec (errorBundlePretty, runParser, some)
31-
3229
defs :: T.Text -> [UnboundEntityDef]
3330
defs = defsWithSettings lowerCaseSettings
3431

0 commit comments

Comments
 (0)