{- -----------------------------------------------------------------------------
Copyright 2020 Kevin P. Barry

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
----------------------------------------------------------------------------- -}

-- Author: Kevin P. Barry [ta0kira@gmail.com]

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- Older versions of Text.Megaparsec are Unsafe. This makes sure that the
-- compiler catches imports into Safe sources when a newer version is used.
{-# LANGUAGE Unsafe #-}

module Parser.TextParser (
  module Text.Megaparsec,
  module Text.Megaparsec.Char,
  SourceContext,
  TextParser,
  getSourceContext,
  runTextParser,
) where

import Data.Char (isSpace)
import Data.List (dropWhileEnd)
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Data.Set as Set

import Base.CompilerError
import Base.CompilerMessage


type TextParser = Parsec CompilerMessage String

instance ErrorContextM TextParser where
  compilerErrorM :: forall a. String -> TextParser a
compilerErrorM = CompilerMessage -> ParsecT CompilerMessage String Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CompilerMessage -> ParsecT CompilerMessage String Identity a)
-> (String -> CompilerMessage)
-> String
-> ParsecT CompilerMessage String Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CompilerMessage
compilerMessage
  withContextM :: forall a. TextParser a -> String -> TextParser a
withContextM     TextParser a
x String
e = (ParseError String CompilerMessage
 -> ParseError String CompilerMessage)
-> TextParser a -> TextParser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(ParseError s e -> ParseError s e) -> m a -> m a
region ((CompilerMessage -> CompilerMessage)
-> ParseError String CompilerMessage
-> ParseError String CompilerMessage
forall e' e s.
Ord e' =>
(e -> e') -> ParseError s e -> ParseError s e'
mapParseError (String -> CompilerMessage -> CompilerMessage
pushErrorScope String
e) (ParseError String CompilerMessage
 -> ParseError String CompilerMessage)
-> (ParseError String CompilerMessage
    -> ParseError String CompilerMessage)
-> ParseError String CompilerMessage
-> ParseError String CompilerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError String CompilerMessage
-> ParseError String CompilerMessage
promoteError) TextParser a
x
  summarizeErrorsM :: forall a. TextParser a -> String -> TextParser a
summarizeErrorsM TextParser a
x String
e = (ParseError String CompilerMessage
 -> ParseError String CompilerMessage)
-> TextParser a -> TextParser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(ParseError s e -> ParseError s e) -> m a -> m a
region ((CompilerMessage -> CompilerMessage)
-> ParseError String CompilerMessage
-> ParseError String CompilerMessage
forall e' e s.
Ord e' =>
(e -> e') -> ParseError s e -> ParseError s e'
mapParseError (String -> CompilerMessage -> CompilerMessage
pushErrorScope String
e) (ParseError String CompilerMessage
 -> ParseError String CompilerMessage)
-> (ParseError String CompilerMessage
    -> ParseError String CompilerMessage)
-> ParseError String CompilerMessage
-> ParseError String CompilerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError String CompilerMessage
-> ParseError String CompilerMessage
promoteError) TextParser a
x

instance ShowErrorComponent CompilerMessage where
  showErrorComponent :: CompilerMessage -> String
showErrorComponent = CompilerMessage -> String
forall a. Show a => a -> String
show

runTextParser :: ErrorContextM m => TextParser a -> String -> String -> m a
runTextParser :: forall (m :: * -> *) a.
ErrorContextM m =>
TextParser a -> String -> String -> m a
runTextParser TextParser a
p String
n String
s = case TextParser a
-> String
-> String
-> Either (ParseErrorBundle String CompilerMessage) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse TextParser a
p String
n String
s of
                           Left ParseErrorBundle String CompilerMessage
e  -> String -> m a
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle String CompilerMessage -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle String CompilerMessage
e
                           Right a
x -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

newtype SourceContext = SourceContext SourcePos deriving (SourceContext -> SourceContext -> Bool
(SourceContext -> SourceContext -> Bool)
-> (SourceContext -> SourceContext -> Bool) -> Eq SourceContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SourceContext -> SourceContext -> Bool
== :: SourceContext -> SourceContext -> Bool
$c/= :: SourceContext -> SourceContext -> Bool
/= :: SourceContext -> SourceContext -> Bool
Eq,Eq SourceContext
Eq SourceContext =>
(SourceContext -> SourceContext -> Ordering)
-> (SourceContext -> SourceContext -> Bool)
-> (SourceContext -> SourceContext -> Bool)
-> (SourceContext -> SourceContext -> Bool)
-> (SourceContext -> SourceContext -> Bool)
-> (SourceContext -> SourceContext -> SourceContext)
-> (SourceContext -> SourceContext -> SourceContext)
-> Ord SourceContext
SourceContext -> SourceContext -> Bool
SourceContext -> SourceContext -> Ordering
SourceContext -> SourceContext -> SourceContext
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SourceContext -> SourceContext -> Ordering
compare :: SourceContext -> SourceContext -> Ordering
$c< :: SourceContext -> SourceContext -> Bool
< :: SourceContext -> SourceContext -> Bool
$c<= :: SourceContext -> SourceContext -> Bool
<= :: SourceContext -> SourceContext -> Bool
$c> :: SourceContext -> SourceContext -> Bool
> :: SourceContext -> SourceContext -> Bool
$c>= :: SourceContext -> SourceContext -> Bool
>= :: SourceContext -> SourceContext -> Bool
$cmax :: SourceContext -> SourceContext -> SourceContext
max :: SourceContext -> SourceContext -> SourceContext
$cmin :: SourceContext -> SourceContext -> SourceContext
min :: SourceContext -> SourceContext -> SourceContext
Ord)

instance Show SourceContext where
  show :: SourceContext -> String
show (SourceContext (SourcePos String
f Pos
l Pos
c)) =
    String
"line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Pos -> Int
unPos Pos
l) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" column " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Pos -> Int
unPos Pos
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f

getSourceContext :: TextParser SourceContext
getSourceContext :: TextParser SourceContext
getSourceContext = (SourcePos -> SourceContext)
-> ParsecT CompilerMessage String Identity SourcePos
-> TextParser SourceContext
forall a b.
(a -> b)
-> ParsecT CompilerMessage String Identity a
-> ParsecT CompilerMessage String Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SourcePos -> SourceContext
SourceContext ParsecT CompilerMessage String Identity SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos

promoteError :: ParseError String CompilerMessage -> ParseError String CompilerMessage
promoteError :: ParseError String CompilerMessage
-> ParseError String CompilerMessage
promoteError e :: ParseError String CompilerMessage
e@(TrivialError Int
i Maybe (ErrorItem (Token String))
_ Set (ErrorItem (Token String))
_) = Int
-> Set (ErrorFancy CompilerMessage)
-> ParseError String CompilerMessage
forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
FancyError Int
i (Set (ErrorFancy CompilerMessage)
 -> ParseError String CompilerMessage)
-> Set (ErrorFancy CompilerMessage)
-> ParseError String CompilerMessage
forall a b. (a -> b) -> a -> b
$ [ErrorFancy CompilerMessage] -> Set (ErrorFancy CompilerMessage)
forall a. Ord a => [a] -> Set a
Set.fromList [CompilerMessage -> ErrorFancy CompilerMessage
forall e. e -> ErrorFancy e
ErrorCustom (CompilerMessage -> ErrorFancy CompilerMessage)
-> CompilerMessage -> ErrorFancy CompilerMessage
forall a b. (a -> b) -> a -> b
$ String -> CompilerMessage
compilerMessage (String -> CompilerMessage) -> String -> CompilerMessage
forall a b. (a -> b) -> a -> b
$ ParseError String CompilerMessage -> String
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> String
parseErrorTextPretty ParseError String CompilerMessage
e]
promoteError ParseError String CompilerMessage
e = ParseError String CompilerMessage
e