Fix GHC 9.8 warnings

This commit is contained in:
Eugen Wissner 2024-08-06 18:18:25 +02:00
parent e02463f452
commit 388af30b51
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
3 changed files with 56 additions and 57 deletions

View File

@ -21,8 +21,7 @@ extra-source-files:
CHANGELOG.md
README.md
tested-with:
GHC == 9.4.7,
GHC == 9.6.3
GHC == 9.8.2
source-repository head
type: git

View File

@ -30,6 +30,7 @@ module Language.GraphQL.AST.Lexer
) where
import Control.Applicative (Alternative(..))
import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
import Data.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, ord)
import Data.Foldable (foldl')
import Data.List (dropWhileEnd)
@ -37,22 +38,22 @@ import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty(..))
import Data.Proxy (Proxy(..))
import Data.Void (Void)
import Text.Megaparsec ( Parsec
, (<?>)
, between
, chunk
, chunkToTokens
, notFollowedBy
, oneOf
, option
, optional
, satisfy
, sepBy
, skipSome
, takeP
, takeWhile1P
, try
)
import Text.Megaparsec
( Parsec
, (<?>)
, between
, chunk
, chunkToTokens
, notFollowedBy
, oneOf
, option
, optional
, satisfy
, skipSome
, takeP
, takeWhile1P
, try
)
import Text.Megaparsec.Char (char, digitChar, space1)
import qualified Text.Megaparsec.Char.Lexer as Lexer
import Data.Text (Text)
@ -142,12 +143,13 @@ blockString :: Parser T.Text
blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
where
stringValue = do
byLine <- sepBy (many blockStringCharacter) lineTerminator
let indentSize = foldr countIndent 0 $ tail byLine
withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine)
byLine <- NonEmpty.sepBy1 (many blockStringCharacter) lineTerminator
let indentSize = foldr countIndent 0 $ NonEmpty.tail byLine
withoutIndent = NonEmpty.head byLine
: (removeIndent indentSize <$> NonEmpty.tail byLine)
withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent
return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines
pure $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines
removeEmptyLine [] = True
removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x)
removeEmptyLine _ = False
@ -180,10 +182,10 @@ name :: Parser T.Text
name = do
firstLetter <- nameFirstLetter
rest <- many $ nameFirstLetter <|> digitChar
_ <- spaceConsumer
return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest
where
nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'
void spaceConsumer
pure $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest
where
nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'
isChunkDelimiter :: Char -> Bool
isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r']
@ -197,25 +199,25 @@ lineTerminator = chunk "\r\n" <|> chunk "\n" <|> chunk "\r"
isSourceCharacter :: Char -> Bool
isSourceCharacter = isSourceCharacter' . ord
where
isSourceCharacter' code = code >= 0x0020
|| code == 0x0009
|| code == 0x000a
|| code == 0x000d
isSourceCharacter' code
= code >= 0x0020
|| elem code [0x0009, 0x000a, 0x000d]
escapeSequence :: Parser Char
escapeSequence = do
_ <- char '\\'
void $ char '\\'
escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u']
case escaped of
'b' -> return '\b'
'f' -> return '\f'
'n' -> return '\n'
'r' -> return '\r'
't' -> return '\t'
'u' -> chr . foldl' step 0
. chunkToTokens (Proxy :: Proxy T.Text)
<$> takeP Nothing 4
_ -> return escaped
'b' -> pure '\b'
'f' -> pure '\f'
'n' -> pure '\n'
'r' -> pure '\r'
't' -> pure '\t'
'u' -> chr
. foldl' step 0
. chunkToTokens (Proxy :: Proxy T.Text)
<$> takeP Nothing 4
_ -> pure escaped
where
step accumulator = (accumulator * 16 +) . digitToInt

View File

@ -50,14 +50,15 @@ import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT(..), ask, asks, mapReaderT)
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
import Data.Bifunctor (first)
import Data.Foldable (find, fold, foldl', toList)
import Data.Foldable (Foldable(..), find)
import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.List (groupBy, sortBy, sortOn)
import Data.List (sortBy)
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Ord (comparing)
import Data.Sequence (Seq(..), (|>))
import qualified Data.Sequence as Seq
@ -253,14 +254,16 @@ findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location])
-> Full.Location
-> String
-> RuleT m
findDuplicates filterByName thisLocation errorMessage = do
ast' <- asks ast
let locations' = foldr filterByName [] ast'
if length locations' > 1 && head locations' == thisLocation
then pure $ error' locations'
else lift mempty
findDuplicates filterByName thisLocation errorMessage =
asks ast >>= go . foldr filterByName []
where
error' locations' = Error
go locations' =
case locations' of
headLocation : otherLocations -- length locations' > 1
| not $ null otherLocations
, headLocation == thisLocation -> pure $ makeError locations'
_ -> lift mempty
makeError locations' = Error
{ message = errorMessage
, locations = locations'
}
@ -536,11 +539,6 @@ uniqueDirectiveNamesRule = DirectivesRule
extract (Full.Directive directiveName _ location') =
(directiveName, location')
groupSorted :: forall a. (a -> Text) -> [a] -> [[a]]
groupSorted getName = groupBy equalByName . sortOn getName
where
equalByName lhs rhs = getName lhs == getName rhs
filterDuplicates :: forall a
. (a -> (Text, Full.Location))
-> String
@ -549,12 +547,12 @@ filterDuplicates :: forall a
filterDuplicates extract nodeType = Seq.fromList
. fmap makeError
. filter ((> 1) . length)
. groupSorted getName
. NonEmpty.groupAllWith getName
where
getName = fst . extract
makeError directives' = Error
{ message = makeMessage $ head directives'
, locations = snd . extract <$> directives'
{ message = makeMessage $ NonEmpty.head directives'
, locations = snd . extract <$> toList directives'
}
makeMessage directive = concat
[ "There can be only one "