Internal.hs

{-# LANGUAGE NamedFieldPuns             #-}

module Data.Morpheus.Parsing.Internal.Internal
  ( Parser
  , Position
  , getLocation
  , processParser
  )
where

import qualified Data.List.NonEmpty            as NonEmpty
import           Data.Morpheus.Types.Internal.AST
                                                ( Position(..)
                                                , GQLError(..)
                                                , GQLErrors
                                                )
import           Data.Morpheus.Types.Internal.Resolving
                                                ( Eventless
                                                , failure
                                                , Result(..)
                                                )
import           Data.Text                      ( Text
                                                , pack
                                                )
import           Text.Megaparsec                ( ParseError
                                                , ParseErrorBundle
                                                  ( ParseErrorBundle
                                                  )
                                                , ParsecT
                                                , SourcePos
                                                , attachSourcePos
                                                , bundleErrors
                                                , bundlePosState
                                                , errorOffset
                                                , getSourcePos
                                                , parseErrorPretty
                                                , runParserT
                                                , SourcePos(..)
                                                , unPos
                                                )
import           Data.Void                      (Void)

getLocation :: Parser Position
getLocation = fmap toLocation getSourcePos

toLocation :: SourcePos -> Position
toLocation SourcePos { sourceLine, sourceColumn } =
  Position { line = unPos sourceLine, column = unPos sourceColumn }

type MyError = Void
type Parser = ParsecT MyError Text Eventless
type ErrorBundle = ParseErrorBundle Text MyError

processParser :: Parser a -> Text -> Eventless a
processParser parser txt = case runParserT parser [] txt of
  Success { result } -> case result of
    Right root       -> pure root
    Left  parseError -> failure (processErrorBundle parseError) 
  Failure { errors } -> failure errors

processErrorBundle :: ErrorBundle -> GQLErrors
processErrorBundle = map parseErrorToGQLError . bundleToErrors
 where
  parseErrorToGQLError :: (ParseError Text MyError, SourcePos) -> GQLError
  parseErrorToGQLError (err, position) = GQLError
    { message   = pack (parseErrorPretty err)
      , locations = [toLocation position]
    }
  bundleToErrors
    :: ErrorBundle -> [(ParseError Text MyError, SourcePos)]
  bundleToErrors ParseErrorBundle { bundleErrors, bundlePosState } =
    NonEmpty.toList $ fst $ attachSourcePos errorOffset
                                            bundleErrors
                                            bundlePosState