diff options
Diffstat (limited to 'src/Language/GraphQL')
| -rw-r--r-- | src/Language/GraphQL/AST/Lexer.hs | 78 | ||||
| -rw-r--r-- | src/Language/GraphQL/Validate/Rules.hs | 32 |
2 files changed, 55 insertions, 55 deletions
diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs index 2d91b9d..62cf4d2 100644 --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -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 diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 2d7adba..e60d39d 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -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 " |