module Language.PureScript.CST.Monad where

import Prelude

import Data.List (sortOn)
import qualified Data.List.NonEmpty as NE
import Data.Ord (comparing)
import Data.Text (Text)
import Language.PureScript.CST.Errors
import Language.PureScript.CST.Layout
import Language.PureScript.CST.Positions
import Language.PureScript.CST.Types

type LexResult = Either (LexState, ParserError) SourceToken

data LexState = LexState
  { LexState -> SourcePos
lexPos :: SourcePos
  , LexState -> [Comment LineFeed]
lexLeading :: [Comment LineFeed]
  , LexState -> Text
lexSource :: Text
  , LexState -> LayoutStack
lexStack :: LayoutStack
  } deriving (Int -> LexState -> ShowS
[LexState] -> ShowS
LexState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LexState] -> ShowS
$cshowList :: [LexState] -> ShowS
show :: LexState -> String
$cshow :: LexState -> String
showsPrec :: Int -> LexState -> ShowS
$cshowsPrec :: Int -> LexState -> ShowS
Show)

data ParserState = ParserState
  { ParserState -> [LexResult]
parserBuff :: [LexResult]
  , ParserState -> [ParserError]
parserErrors :: [ParserError]
  , ParserState -> [ParserWarning]
parserWarnings :: [ParserWarning]
  } deriving (Int -> ParserState -> ShowS
[ParserState] -> ShowS
ParserState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParserState] -> ShowS
$cshowList :: [ParserState] -> ShowS
show :: ParserState -> String
$cshow :: ParserState -> String
showsPrec :: Int -> ParserState -> ShowS
$cshowsPrec :: Int -> ParserState -> ShowS
Show)

-- | A bare bones, CPS'ed `StateT s (Except e) a`.
newtype ParserM e s a =
  Parser (forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)

type Parser = ParserM ParserError ParserState

instance Functor (ParserM e s) where
  {-# INLINE fmap #-}
  fmap :: forall a b. (a -> b) -> ParserM e s a -> ParserM e s b
fmap a -> b
f (Parser forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r
k) =
    forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \s
st s -> e -> r
kerr s -> b -> r
ksucc ->
      forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r
k s
st s -> e -> r
kerr (\s
st' a
a -> s -> b -> r
ksucc s
st' (a -> b
f a
a))

instance Applicative (ParserM e s) where
  {-# INLINE pure #-}
  pure :: forall a. a -> ParserM e s a
pure a
a = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \s
st s -> e -> r
_ s -> a -> r
k -> s -> a -> r
k s
st a
a
  {-# INLINE (<*>) #-}
  Parser forall r. s -> (s -> e -> r) -> (s -> (a -> b) -> r) -> r
k1 <*> :: forall a b. ParserM e s (a -> b) -> ParserM e s a -> ParserM e s b
<*> Parser forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r
k2 =
    forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \s
st s -> e -> r
kerr s -> b -> r
ksucc ->
      forall r. s -> (s -> e -> r) -> (s -> (a -> b) -> r) -> r
k1 s
st s -> e -> r
kerr forall a b. (a -> b) -> a -> b
$ \s
st' a -> b
f ->
        forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r
k2 s
st' s -> e -> r
kerr forall a b. (a -> b) -> a -> b
$ \s
st'' a
a ->
          s -> b -> r
ksucc s
st'' (a -> b
f a
a)

instance Monad (ParserM e s) where
  {-# INLINE return #-}
  return :: forall a. a -> ParserM e s a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE (>>=) #-}
  Parser forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r
k1 >>= :: forall a b. ParserM e s a -> (a -> ParserM e s b) -> ParserM e s b
>>= a -> ParserM e s b
k2 =
    forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \s
st s -> e -> r
kerr s -> b -> r
ksucc ->
      forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r
k1 s
st s -> e -> r
kerr forall a b. (a -> b) -> a -> b
$ \s
st' a
a -> do
        let Parser forall r. s -> (s -> e -> r) -> (s -> b -> r) -> r
k3 = a -> ParserM e s b
k2 a
a
        forall r. s -> (s -> e -> r) -> (s -> b -> r) -> r
k3 s
st' s -> e -> r
kerr s -> b -> r
ksucc

runParser :: ParserState -> Parser a -> (ParserState, Either (NE.NonEmpty ParserError) a)
runParser :: forall a.
ParserState
-> Parser a -> (ParserState, Either (NonEmpty ParserError) a)
runParser ParserState
st (Parser forall r.
ParserState
-> (ParserState -> ParserError -> r)
-> (ParserState -> a -> r)
-> r
k) = forall r.
ParserState
-> (ParserState -> ParserError -> r)
-> (ParserState -> a -> r)
-> r
k ParserState
st forall {b}.
ParserState
-> ParserError -> (ParserState, Either (NonEmpty ParserError) b)
left forall {b}.
ParserState -> b -> (ParserState, Either (NonEmpty ParserError) b)
right
  where
  left :: ParserState
-> ParserError -> (ParserState, Either (NonEmpty ParserError) b)
left st' :: ParserState
st'@ParserState {[LexResult]
[ParserWarning]
[ParserError]
parserWarnings :: [ParserWarning]
parserErrors :: [ParserError]
parserBuff :: [LexResult]
parserWarnings :: ParserState -> [ParserWarning]
parserErrors :: ParserState -> [ParserError]
parserBuff :: ParserState -> [LexResult]
..} ParserError
err =
    (ParserState
st', forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a. ParserErrorInfo a -> SourceRange
errRange) forall a b. (a -> b) -> a -> b
$ ParserError
err forall a. a -> [a] -> NonEmpty a
NE.:| [ParserError]
parserErrors)

  right :: ParserState -> b -> (ParserState, Either (NonEmpty ParserError) b)
right st' :: ParserState
st'@ParserState {[LexResult]
[ParserWarning]
[ParserError]
parserWarnings :: [ParserWarning]
parserErrors :: [ParserError]
parserBuff :: [LexResult]
parserWarnings :: ParserState -> [ParserWarning]
parserErrors :: ParserState -> [ParserError]
parserBuff :: ParserState -> [LexResult]
..} b
res
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParserError]
parserErrors = (ParserState
st', forall a b. b -> Either a b
Right b
res)
    | Bool
otherwise = (ParserState
st', forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a. ParserErrorInfo a -> SourceRange
errRange [ParserError]
parserErrors)

runTokenParser :: Parser a -> [LexResult] -> Either (NE.NonEmpty ParserError) ([ParserWarning], a)
runTokenParser :: forall a.
Parser a
-> [LexResult]
-> Either (NonEmpty ParserError) ([ParserWarning], a)
runTokenParser Parser a
p [LexResult]
buff = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([ParserWarning]
warnings,) Either (NonEmpty ParserError) a
res
  where
  (ParserState [LexResult]
_ [ParserError]
_ [ParserWarning]
warnings, Either (NonEmpty ParserError) a
res) =
    forall a.
ParserState
-> Parser a -> (ParserState, Either (NonEmpty ParserError) a)
runParser ParserState
initialState Parser a
p

  initialState :: ParserState
initialState = ParserState
    { parserBuff :: [LexResult]
parserBuff = [LexResult]
buff
    , parserErrors :: [ParserError]
parserErrors = []
    , parserWarnings :: [ParserWarning]
parserWarnings = []
    }

{-# INLINE throw #-}
throw :: e -> ParserM e s a
throw :: forall e s a. e -> ParserM e s a
throw e
e = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \s
st s -> e -> r
kerr s -> a -> r
_ -> s -> e -> r
kerr s
st e
e

parseError :: SourceToken -> Parser a
parseError :: forall a. SourceToken -> Parser a
parseError SourceToken
tok = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \ParserState
st ParserState -> ParserError -> r
kerr ParserState -> a -> r
_ ->
  ParserState -> ParserError -> r
kerr ParserState
st forall a b. (a -> b) -> a -> b
$ ParserErrorInfo
    { errRange :: SourceRange
errRange = TokenAnn -> SourceRange
tokRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceToken -> TokenAnn
tokAnn forall a b. (a -> b) -> a -> b
$ SourceToken
tok
    , errToks :: [SourceToken]
errToks = [SourceToken
tok]
    , errStack :: LayoutStack
errStack = [] -- TODO parserStack st
    , errType :: ParserErrorType
errType = ParserErrorType
ErrToken
    }

mkParserError :: LayoutStack -> [SourceToken] -> a -> ParserErrorInfo a
mkParserError :: forall a. LayoutStack -> [SourceToken] -> a -> ParserErrorInfo a
mkParserError LayoutStack
stack [SourceToken]
toks a
ty =
  ParserErrorInfo
    { errRange :: SourceRange
errRange =  SourceRange
range
    , errToks :: [SourceToken]
errToks = [SourceToken]
toks
    , errStack :: LayoutStack
errStack = LayoutStack
stack
    , errType :: a
errType = a
ty
    }
  where
  range :: SourceRange
range = case [SourceToken]
toks of
    [] -> SourcePos -> SourcePos -> SourceRange
SourceRange (Int -> Int -> SourcePos
SourcePos Int
0 Int
0) (Int -> Int -> SourcePos
SourcePos Int
0 Int
0)
    [SourceToken]
_  -> SourceRange -> SourceRange -> SourceRange
widen (TokenAnn -> SourceRange
tokRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceToken -> TokenAnn
tokAnn forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [SourceToken]
toks) (TokenAnn -> SourceRange
tokRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceToken -> TokenAnn
tokAnn forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [SourceToken]
toks)

addFailure :: [SourceToken] -> ParserErrorType -> Parser ()
addFailure :: [SourceToken] -> ParserErrorType -> Parser ()
addFailure [SourceToken]
toks ParserErrorType
ty = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \ParserState
st ParserState -> ParserError -> r
_ ParserState -> () -> r
ksucc ->
  ParserState -> () -> r
ksucc (ParserState
st { parserErrors :: [ParserError]
parserErrors = forall a. LayoutStack -> [SourceToken] -> a -> ParserErrorInfo a
mkParserError [] [SourceToken]
toks ParserErrorType
ty forall a. a -> [a] -> [a]
: ParserState -> [ParserError]
parserErrors ParserState
st }) ()

parseFail' :: [SourceToken] -> ParserErrorType -> Parser a
parseFail' :: forall a. [SourceToken] -> ParserErrorType -> Parser a
parseFail' [SourceToken]
toks ParserErrorType
msg = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \ParserState
st ParserState -> ParserError -> r
kerr ParserState -> a -> r
_ -> ParserState -> ParserError -> r
kerr ParserState
st (forall a. LayoutStack -> [SourceToken] -> a -> ParserErrorInfo a
mkParserError [] [SourceToken]
toks ParserErrorType
msg)

parseFail :: SourceToken -> ParserErrorType -> Parser a
parseFail :: forall a. SourceToken -> ParserErrorType -> Parser a
parseFail = forall a. [SourceToken] -> ParserErrorType -> Parser a
parseFail' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

addWarning :: [SourceToken] -> ParserWarningType -> Parser ()
addWarning :: [SourceToken] -> ParserWarningType -> Parser ()
addWarning [SourceToken]
toks ParserWarningType
ty = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \ParserState
st ParserState -> ParserError -> r
_ ParserState -> () -> r
ksucc ->
  ParserState -> () -> r
ksucc (ParserState
st { parserWarnings :: [ParserWarning]
parserWarnings = forall a. LayoutStack -> [SourceToken] -> a -> ParserErrorInfo a
mkParserError [] [SourceToken]
toks ParserWarningType
ty forall a. a -> [a] -> [a]
: ParserState -> [ParserWarning]
parserWarnings ParserState
st }) ()

pushBack :: SourceToken -> Parser ()
pushBack :: SourceToken -> Parser ()
pushBack SourceToken
tok = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \ParserState
st ParserState -> ParserError -> r
_ ParserState -> () -> r
ksucc ->
  ParserState -> () -> r
ksucc (ParserState
st { parserBuff :: [LexResult]
parserBuff = forall a b. b -> Either a b
Right SourceToken
tok forall a. a -> [a] -> [a]
: ParserState -> [LexResult]
parserBuff ParserState
st }) ()

{-# INLINE tryPrefix #-}
tryPrefix :: Parser a -> Parser b -> Parser (Maybe a, b)
tryPrefix :: forall a b. Parser a -> Parser b -> Parser (Maybe a, b)
tryPrefix (Parser forall r.
ParserState
-> (ParserState -> ParserError -> r)
-> (ParserState -> a -> r)
-> r
lhs) Parser b
rhs = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \ParserState
st ParserState -> ParserError -> r
kerr ParserState -> (Maybe a, b) -> r
ksucc ->
  forall r.
ParserState
-> (ParserState -> ParserError -> r)
-> (ParserState -> a -> r)
-> r
lhs ParserState
st
    (\ParserState
_ ParserError
_ -> do
      let Parser forall r.
ParserState
-> (ParserState -> ParserError -> r)
-> (ParserState -> (Maybe a, b) -> r)
-> r
k = (forall a. Maybe a
Nothing,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser b
rhs
      forall r.
ParserState
-> (ParserState -> ParserError -> r)
-> (ParserState -> (Maybe a, b) -> r)
-> r
k ParserState
st ParserState -> ParserError -> r
kerr ParserState -> (Maybe a, b) -> r
ksucc)
    (\ParserState
st' a
res -> do
      let Parser forall r.
ParserState
-> (ParserState -> ParserError -> r)
-> (ParserState -> (Maybe a, b) -> r)
-> r
k = (forall a. a -> Maybe a
Just a
res,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser b
rhs
      forall r.
ParserState
-> (ParserState -> ParserError -> r)
-> (ParserState -> (Maybe a, b) -> r)
-> r
k ParserState
st' ParserState -> ParserError -> r
kerr ParserState -> (Maybe a, b) -> r
ksucc)

oneOf :: NE.NonEmpty (Parser a) -> Parser a
oneOf :: forall a. NonEmpty (Parser a) -> Parser a
oneOf NonEmpty (Parser a)
parsers = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \ParserState
st ParserState -> ParserError -> r
kerr ParserState -> a -> r
ksucc -> do
  let
    prevErrs :: [ParserError]
prevErrs = ParserState -> [ParserError]
parserErrors ParserState
st
    go :: (a, Either (NonEmpty (ParserErrorInfo a)) b)
-> (a, Either (NonEmpty (ParserErrorInfo a)) b)
-> (a, Either (NonEmpty (ParserErrorInfo a)) b)
go (a
st', Right b
a) (a, Either (NonEmpty (ParserErrorInfo a)) b)
_ = (a
st', forall a b. b -> Either a b
Right b
a)
    go (a, Either (NonEmpty (ParserErrorInfo a)) b)
_ (a
st', Right b
a) = (a
st', forall a b. b -> Either a b
Right b
a)
    go (a
st1, Left NonEmpty (ParserErrorInfo a)
errs1) (a
st2, Left NonEmpty (ParserErrorInfo a)
errs2)
      | forall a. ParserErrorInfo a -> SourceRange
errRange (forall a. NonEmpty a -> a
NE.last NonEmpty (ParserErrorInfo a)
errs2) forall a. Ord a => a -> a -> Bool
> forall a. ParserErrorInfo a -> SourceRange
errRange (forall a. NonEmpty a -> a
NE.last NonEmpty (ParserErrorInfo a)
errs1) = (a
st2, forall a b. a -> Either a b
Left NonEmpty (ParserErrorInfo a)
errs2)
      | Bool
otherwise = (a
st1, forall a b. a -> Either a b
Left NonEmpty (ParserErrorInfo a)
errs1)
  case forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall {a} {a} {b}.
(a, Either (NonEmpty (ParserErrorInfo a)) b)
-> (a, Either (NonEmpty (ParserErrorInfo a)) b)
-> (a, Either (NonEmpty (ParserErrorInfo a)) b)
go forall a b. (a -> b) -> a -> b
$ forall a.
ParserState
-> Parser a -> (ParserState, Either (NonEmpty ParserError) a)
runParser (ParserState
st { parserErrors :: [ParserError]
parserErrors = [] }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Parser a)
parsers of
    (ParserState
st', Left NonEmpty ParserError
errs) -> ParserState -> ParserError -> r
kerr (ParserState
st' { parserErrors :: [ParserError]
parserErrors = [ParserError]
prevErrs forall a. Semigroup a => a -> a -> a
<> forall a. NonEmpty a -> [a]
NE.tail NonEmpty ParserError
errs}) forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.head NonEmpty ParserError
errs
    (ParserState
st', Right a
res) -> ParserState -> a -> r
ksucc (ParserState
st' { parserErrors :: [ParserError]
parserErrors = [ParserError]
prevErrs }) a
res

manyDelimited :: Token -> Token -> Token -> Parser a -> Parser [a]
manyDelimited :: forall a. Token -> Token -> Token -> Parser a -> Parser [a]
manyDelimited Token
open Token
close Token
sep Parser a
p = do
  SourceToken
_   <- Token -> Parser SourceToken
token Token
open
  [a]
res <- Parser [a]
go1
  SourceToken
_   <- Token -> Parser SourceToken
token Token
close
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
res
  where
  go1 :: Parser [a]
go1 =
    forall a. NonEmpty (Parser a) -> Parser a
oneOf forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList
      [ [a] -> Parser [a]
go2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser a
p
      , forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      ]

  go2 :: [a] -> Parser [a]
go2 [a]
acc =
    forall a. NonEmpty (Parser a) -> Parser a
oneOf forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList
      [ Token -> Parser SourceToken
token Token
sep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([a] -> Parser [a]
go2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [a]
acc) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser a
p)
      , forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> [a]
reverse [a]
acc)
      ]

token :: Token -> Parser SourceToken
token :: Token -> Parser SourceToken
token Token
t = do
  SourceToken
t' <- Parser SourceToken
munch
  if Token
t forall a. Eq a => a -> a -> Bool
== SourceToken -> Token
tokValue SourceToken
t'
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure SourceToken
t'
    else forall a. SourceToken -> Parser a
parseError SourceToken
t'

munch :: Parser SourceToken
munch :: Parser SourceToken
munch = forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
Parser forall a b. (a -> b) -> a -> b
$ \state :: ParserState
state@ParserState {[LexResult]
[ParserWarning]
[ParserError]
parserWarnings :: [ParserWarning]
parserErrors :: [ParserError]
parserBuff :: [LexResult]
parserWarnings :: ParserState -> [ParserWarning]
parserErrors :: ParserState -> [ParserError]
parserBuff :: ParserState -> [LexResult]
..} ParserState -> ParserError -> r
kerr ParserState -> SourceToken -> r
ksucc ->
  case [LexResult]
parserBuff of
    Right SourceToken
tok : [LexResult]
parserBuff' ->
      ParserState -> SourceToken -> r
ksucc (ParserState
state { parserBuff :: [LexResult]
parserBuff = [LexResult]
parserBuff' }) SourceToken
tok
    Left (LexState
_,  ParserError
err) : [LexResult]
_ ->
      ParserState -> ParserError -> r
kerr ParserState
state ParserError
err
    [] ->
      forall a. HasCallStack => String -> a
error String
"Empty input"