{-# LANGUAGE TupleSections, DeriveGeneric, OverloadedStrings, CPP, NamedFieldPuns #-}
module Sugar.Parser
  ( Token(..)
  , TokenStep
  , TokenNote
  , ParseError
  , Parser(..)
  , flatten
  , sugarParse
  , sugarParseTopLevel
  , sugarParseMap
  , sugarParseList
  ) where

import Control.Monad
import Control.Applicative

import qualified Data.Text as T

import Sugar.Types
import Sugar.Lexer

data Token
  = Token'Unit TokenNote
  | Token'Text String TokenNote
  | Token'List [TokenStep] Wrap TokenNote
  | Token'Map [(TokenStep,TokenStep)] TokenNote
  deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show, Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq)

type TokenStep = (SourceLocation, Token)
type TokenNote = Maybe [TokenStep]
type ParseError = (Maybe SourceLocation, String)

newtype Parser a = Parser
  { Parser a -> [LexemeStep] -> ([LexemeStep], Either ParseError a)
runParser :: [LexemeStep] -> ([LexemeStep], Either ParseError a) }

instance Functor Parser where
  fmap :: (a -> b) -> Parser a -> Parser b
fmap a -> b
f (Parser [LexemeStep] -> ([LexemeStep], Either ParseError a)
g) = ([LexemeStep] -> ([LexemeStep], Either ParseError b)) -> Parser b
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError b)) -> Parser b)
-> ([LexemeStep] -> ([LexemeStep], Either ParseError b))
-> Parser b
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> let ([LexemeStep]
ts', Either ParseError a
x) = [LexemeStep] -> ([LexemeStep], Either ParseError a)
g [LexemeStep]
ts in ([LexemeStep]
ts', (a -> b) -> Either ParseError a -> Either ParseError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Either ParseError a
x)

instance Applicative Parser where
  pure :: a -> Parser a
pure a
x = ([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a)
-> ([LexemeStep] -> ([LexemeStep], Either ParseError a))
-> Parser a
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> ([LexemeStep]
ts, a -> Either ParseError a
forall a b. b -> Either a b
Right a
x)
  Parser (a -> b)
p <*> :: Parser (a -> b) -> Parser a -> Parser b
<*> Parser a
q = ([LexemeStep] -> ([LexemeStep], Either ParseError b)) -> Parser b
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError b)) -> Parser b)
-> ([LexemeStep] -> ([LexemeStep], Either ParseError b))
-> Parser b
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> let ([LexemeStep]
ts',Either ParseError (a -> b)
x) = Parser (a -> b)
-> [LexemeStep] -> ([LexemeStep], Either ParseError (a -> b))
forall a.
Parser a -> [LexemeStep] -> ([LexemeStep], Either ParseError a)
runParser Parser (a -> b)
p [LexemeStep]
ts in case Either ParseError (a -> b)
x of
    Left ParseError
a -> ([LexemeStep]
ts', ParseError -> Either ParseError b
forall a b. a -> Either a b
Left ParseError
a)
    Right a -> b
b -> Parser b -> [LexemeStep] -> ([LexemeStep], Either ParseError b)
forall a.
Parser a -> [LexemeStep] -> ([LexemeStep], Either ParseError a)
runParser ((a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
b Parser a
q) [LexemeStep]
ts'

instance Alternative Parser where
  empty :: Parser a
empty = ([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a)
-> ([LexemeStep] -> ([LexemeStep], Either ParseError a))
-> Parser a
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> ([LexemeStep]
ts, ParseError -> Either ParseError a
forall a b. a -> Either a b
Left (Maybe SourceLocation
forall a. Maybe a
Nothing, String
""))
  Parser a
p1 <|> :: Parser a -> Parser a -> Parser a
<|> Parser a
p2 = ([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a)
-> ([LexemeStep] -> ([LexemeStep], Either ParseError a))
-> Parser a
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> case Parser a -> [LexemeStep] -> ([LexemeStep], Either ParseError a)
forall a.
Parser a -> [LexemeStep] -> ([LexemeStep], Either ParseError a)
runParser Parser a
p1 [LexemeStep]
ts of
    ([LexemeStep]
ts', Left ParseError
err)
      | [LexemeStep]
ts' [LexemeStep] -> [LexemeStep] -> Bool
forall a. Eq a => a -> a -> Bool
== [LexemeStep]
ts   -> Parser a -> [LexemeStep] -> ([LexemeStep], Either ParseError a)
forall a.
Parser a -> [LexemeStep] -> ([LexemeStep], Either ParseError a)
runParser Parser a
p2 [LexemeStep]
ts
      | Bool
otherwise -> ([LexemeStep]
ts', ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
err)
    ([LexemeStep], Either ParseError a)
success -> ([LexemeStep], Either ParseError a)
success

instance Monad Parser where
  (Parser [LexemeStep] -> ([LexemeStep], Either ParseError a)
p) >>= :: Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
f = ([LexemeStep] -> ([LexemeStep], Either ParseError b)) -> Parser b
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError b)) -> Parser b)
-> ([LexemeStep] -> ([LexemeStep], Either ParseError b))
-> Parser b
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> let ([LexemeStep]
ts',Either ParseError a
x) = [LexemeStep] -> ([LexemeStep], Either ParseError a)
p [LexemeStep]
ts in case Either ParseError a
x of
    Left ParseError
a -> ([LexemeStep]
ts', ParseError -> Either ParseError b
forall a b. a -> Either a b
Left ParseError
a)
    Right a
b -> Parser b -> [LexemeStep] -> ([LexemeStep], Either ParseError b)
forall a.
Parser a -> [LexemeStep] -> ([LexemeStep], Either ParseError a)
runParser (a -> Parser b
f a
b) [LexemeStep]
ts'

--

flatten :: TokenStep -> Sugar
flatten :: TokenStep -> Sugar
flatten (SourceLocation
_, Token
s) = case Token
s of
  Token'Unit TokenNote
note -> Note -> Sugar
Sugar'Unit ((TokenStep -> Sugar) -> [TokenStep] -> [Sugar]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TokenStep -> Sugar
flatten ([TokenStep] -> [Sugar]) -> TokenNote -> Note
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TokenNote
note)
  Token'Text String
str TokenNote
note -> Text -> Note -> Sugar
Sugar'Text (String -> Text
T.pack String
str) ((TokenStep -> Sugar) -> [TokenStep] -> [Sugar]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TokenStep -> Sugar
flatten ([TokenStep] -> [Sugar]) -> TokenNote -> Note
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TokenNote
note)
  Token'List [TokenStep]
elems Wrap
wrap TokenNote
note -> [Sugar] -> Wrap -> Note -> Sugar
Sugar'List (TokenStep -> Sugar
flatten (TokenStep -> Sugar) -> [TokenStep] -> [Sugar]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TokenStep]
elems) Wrap
wrap ((TokenStep -> Sugar) -> [TokenStep] -> [Sugar]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TokenStep -> Sugar
flatten ([TokenStep] -> [Sugar]) -> TokenNote -> Note
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TokenNote
note)
  Token'Map [(TokenStep, TokenStep)]
elems TokenNote
note -> [(Sugar, Sugar)] -> Note -> Sugar
Sugar'Map ((\(TokenStep
x,TokenStep
y) -> (TokenStep -> Sugar
flatten TokenStep
x, TokenStep -> Sugar
flatten TokenStep
y)) ((TokenStep, TokenStep) -> (Sugar, Sugar))
-> [(TokenStep, TokenStep)] -> [(Sugar, Sugar)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TokenStep, TokenStep)]
elems) ((TokenStep -> Sugar) -> [TokenStep] -> [Sugar]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TokenStep -> Sugar
flatten ([TokenStep] -> [Sugar]) -> TokenNote -> Note
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TokenNote
note)

--

sugarParse :: Parser TokenStep
sugarParse :: Parser TokenStep
sugarParse = do
  (SourceLocation
loc, Lexeme
tkn) <- Parser LexemeStep
peek
  case Lexeme
tkn of
    Lexeme
Lexeme'Start -> Parser TokenStep
sugarParse
    Lexeme
Lexeme'OpenCurl -> Parser TokenStep
sugarParseMap
    Lexeme
Lexeme'OpenParen -> Parser TokenStep -> Parser TokenStep
forall a. Parser a -> Parser a
try Parser TokenStep
sugarParseUnit Parser TokenStep -> Parser TokenStep -> Parser TokenStep
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TokenStep
sugarParseParenList
    Lexeme
Lexeme'OpenSquare -> Parser TokenStep
sugarParseSquareList
    Lexeme
Lexeme'QuoteStart -> Parser TokenStep
sugarParseQuote
    Lexeme
Lexeme'StringStart -> Parser TokenStep
sugarParseText
    Lexeme
Lexeme'SingleLineComment -> Parser LexemeStep
nextLexeme Parser LexemeStep -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SourceLocation -> Parser ()
ignoreUntilNewLine SourceLocation
loc Parser () -> Parser TokenStep -> Parser TokenStep
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser TokenStep
sugarParse
    Lexeme
Lexeme'MultiLineCommentStart -> Parser LexemeStep
nextLexeme Parser LexemeStep -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser ()
ignoreUntilMultilineCommentEnd Int
0 Parser () -> Parser TokenStep -> Parser TokenStep
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser TokenStep
sugarParse
    Lexeme
_ -> LexemeStep -> Parser TokenStep
sugarParseUnexpected (SourceLocation
loc, Lexeme
tkn)

ignoreUntilNewLine :: SourceLocation -> Parser ()
ignoreUntilNewLine :: SourceLocation -> Parser ()
ignoreUntilNewLine SourceLocation
sl = do
  Maybe LexemeStep
tkn' <- Parser (Maybe LexemeStep)
tryPeek
  case Maybe LexemeStep
tkn' of
    Maybe LexemeStep
Nothing -> () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (SourceLocation
loc,Lexeme
_) -> if SourceLocation -> Int
slLine SourceLocation
loc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== SourceLocation -> Int
slLine SourceLocation
sl
      then Parser LexemeStep
nextLexeme Parser LexemeStep -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SourceLocation -> Parser ()
ignoreUntilNewLine SourceLocation
loc
      else () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

ignoreUntilMultilineCommentEnd :: Int -> Parser ()
ignoreUntilMultilineCommentEnd :: Int -> Parser ()
ignoreUntilMultilineCommentEnd Int
nested = do
  Maybe LexemeStep
tkn' <- Parser (Maybe LexemeStep)
tryPeek
  case Maybe LexemeStep
tkn' of
    Maybe LexemeStep
Nothing -> String -> Parser ()
sugarParseExpected String
"`|#` to close multi-line comment"
    Just (SourceLocation
_,Lexeme
Lexeme'MultiLineCommentStart) -> Parser LexemeStep
nextLexeme Parser LexemeStep -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser ()
ignoreUntilMultilineCommentEnd (Int
nested Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    Just (SourceLocation
_,Lexeme
Lexeme'MultiLineCommentEnd) -> do
      Parser LexemeStep -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser LexemeStep
nextLexeme
      Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nested Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Int -> Parser ()
ignoreUntilMultilineCommentEnd (Int
nested Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    Just (SourceLocation
_,Lexeme
_) -> Parser LexemeStep
nextLexeme Parser LexemeStep -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser ()
ignoreUntilMultilineCommentEnd Int
nested

sugarParseUnexpected :: LexemeStep -> Parser TokenStep
sugarParseUnexpected :: LexemeStep -> Parser TokenStep
sugarParseUnexpected (SourceLocation
loc, Lexeme
tkn) = ([LexemeStep] -> ([LexemeStep], Either ParseError TokenStep))
-> Parser TokenStep
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError TokenStep))
 -> Parser TokenStep)
-> ([LexemeStep] -> ([LexemeStep], Either ParseError TokenStep))
-> Parser TokenStep
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> ([LexemeStep]
ts, ParseError -> Either ParseError TokenStep
forall a b. a -> Either a b
Left (SourceLocation -> Maybe SourceLocation
forall a. a -> Maybe a
Just SourceLocation
loc, String
"Unexpected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Lexeme -> String
forall a. Show a => a -> String
show Lexeme
tkn))

sugarParseExpected :: String -> Parser ()
sugarParseExpected :: String -> Parser ()
sugarParseExpected String
expected =  ([LexemeStep] -> ([LexemeStep], Either ParseError ())) -> Parser ()
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError ()))
 -> Parser ())
-> ([LexemeStep] -> ([LexemeStep], Either ParseError ()))
-> Parser ()
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> ([LexemeStep]
ts, ParseError -> Either ParseError ()
forall a b. a -> Either a b
Left (Maybe SourceLocation
forall a. Maybe a
Nothing, String
"Expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
expected))

sugarParseNote :: Parser (Maybe [TokenStep])
sugarParseNote :: Parser TokenNote
sugarParseNote = do
  Maybe LexemeStep
tkn' <- Parser (Maybe LexemeStep)
tryPeek
  case Maybe LexemeStep
tkn' of
    Maybe LexemeStep
Nothing -> TokenNote -> Parser TokenNote
forall (m :: * -> *) a. Monad m => a -> m a
return TokenNote
forall a. Maybe a
Nothing
    Just (SourceLocation
_,Lexeme
tkn) -> case Lexeme
tkn of
      Lexeme
Lexeme'OpenAngle -> ([TokenStep] -> TokenNote)
-> Parser [TokenStep] -> Parser TokenNote
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TokenStep] -> TokenNote
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parser [TokenStep] -> Parser TokenNote)
-> Parser [TokenStep] -> Parser TokenNote
forall a b. (a -> b) -> a -> b
$ Parser LexemeStep
-> Parser LexemeStep -> Parser [TokenStep] -> Parser [TokenStep]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Lexeme -> Parser LexemeStep
lexeme Lexeme
Lexeme'OpenAngle) (Lexeme -> Parser LexemeStep
lexeme Lexeme
Lexeme'CloseAngle) (Parser TokenStep -> Parser [TokenStep]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser TokenStep
sugarParse)
      Lexeme
_ -> TokenNote -> Parser TokenNote
forall (f :: * -> *) a. Applicative f => a -> f a
pure TokenNote
forall a. Maybe a
Nothing

sugarParseUnit :: Parser TokenStep
sugarParseUnit :: Parser TokenStep
sugarParseUnit = do
  (SourceLocation
sl,  Lexeme
_) <- Lexeme -> Parser LexemeStep
lexeme Lexeme
Lexeme'OpenParen
  (SourceLocation
sl', Lexeme
_) <- Lexeme -> Parser LexemeStep
lexeme Lexeme
Lexeme'CloseParen
  if SourceLocation -> Int
slColumn SourceLocation
sl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==  SourceLocation -> Int
slColumn SourceLocation
sl' -- no space between parens
    then do
      TokenNote
note <- Parser TokenNote
sugarParseNote
      let tkn :: Token
tkn = TokenNote -> Token
Token'Unit TokenNote
note
      TokenStep -> Parser TokenStep
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceLocation
sl, Token
tkn)
    else
      Parser TokenStep
forall (f :: * -> *) a. Alternative f => f a
empty

sugarParseTopLevel :: Parser TokenStep
sugarParseTopLevel :: Parser TokenStep
sugarParseTopLevel = Parser TokenStep
sugarParseTopLevelMap

sugarParseMap :: Parser TokenStep
sugarParseMap :: Parser TokenStep
sugarParseMap = do
  (SourceLocation
sl, Lexeme
_) <- Lexeme -> Parser LexemeStep
lexeme Lexeme
Lexeme'OpenCurl
  [(TokenStep, TokenStep)]
elems <- Parser (TokenStep, TokenStep) -> Parser [(TokenStep, TokenStep)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((,) (TokenStep -> TokenStep -> (TokenStep, TokenStep))
-> Parser TokenStep -> Parser (TokenStep -> (TokenStep, TokenStep))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TokenStep
sugarParse Parser (TokenStep -> (TokenStep, TokenStep))
-> Parser TokenStep -> Parser (TokenStep, TokenStep)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TokenStep
sugarParse)
  Parser LexemeStep -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser LexemeStep -> Parser ()) -> Parser LexemeStep -> Parser ()
forall a b. (a -> b) -> a -> b
$ Lexeme -> Parser LexemeStep
lexeme Lexeme
Lexeme'CloseCurl
  TokenNote
note <- Parser TokenNote
sugarParseNote
  let tkn :: Token
tkn = [(TokenStep, TokenStep)] -> TokenNote -> Token
Token'Map [(TokenStep, TokenStep)]
elems TokenNote
note
  TokenStep -> Parser TokenStep
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceLocation
sl, Token
tkn)

sugarParseTopLevelMap :: Parser TokenStep
sugarParseTopLevelMap :: Parser TokenStep
sugarParseTopLevelMap = do
  [(TokenStep, TokenStep)]
elems <- Parser (TokenStep, TokenStep) -> Parser [(TokenStep, TokenStep)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((,) (TokenStep -> TokenStep -> (TokenStep, TokenStep))
-> Parser TokenStep -> Parser (TokenStep -> (TokenStep, TokenStep))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TokenStep
sugarParse Parser (TokenStep -> (TokenStep, TokenStep))
-> Parser TokenStep -> Parser (TokenStep, TokenStep)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TokenStep
sugarParse)
  let tkn :: Token
tkn = [(TokenStep, TokenStep)] -> TokenNote -> Token
Token'Map [(TokenStep, TokenStep)]
elems TokenNote
forall a. Maybe a
Nothing
  case [(TokenStep, TokenStep)]
elems of
    (((SourceLocation
sl,Token
_), TokenStep
_):[(TokenStep, TokenStep)]
_) -> TokenStep -> Parser TokenStep
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceLocation
sl, Token
tkn)
    [] -> TokenStep -> Parser TokenStep
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> SourceLocation
SourceLocation Int
0 Int
0, Token
tkn)

sugarParseList :: Parser TokenStep
sugarParseList :: Parser TokenStep
sugarParseList = Parser TokenStep -> Parser TokenStep
forall a. Parser a -> Parser a
try Parser TokenStep
sugarParseSquareList Parser TokenStep -> Parser TokenStep -> Parser TokenStep
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TokenStep
sugarParseParenList

sugarParseSquareList :: Parser TokenStep
sugarParseSquareList :: Parser TokenStep
sugarParseSquareList = do
  (SourceLocation
sl, Lexeme
_) <- Lexeme -> Parser LexemeStep
lexeme Lexeme
Lexeme'OpenSquare
  [TokenStep]
elems <- Parser TokenStep -> Parser [TokenStep]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser TokenStep
sugarParse
  Parser LexemeStep -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser LexemeStep -> Parser ()) -> Parser LexemeStep -> Parser ()
forall a b. (a -> b) -> a -> b
$ Lexeme -> Parser LexemeStep
lexeme Lexeme
Lexeme'CloseSquare
  TokenNote
note <- Parser TokenNote
sugarParseNote
  let tkn :: Token
tkn = [TokenStep] -> Wrap -> TokenNote -> Token
Token'List [TokenStep]
elems Wrap
Wrap'Square TokenNote
note
  TokenStep -> Parser TokenStep
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceLocation
sl, Token
tkn)

sugarParseParenList :: Parser TokenStep
sugarParseParenList :: Parser TokenStep
sugarParseParenList = do
  (SourceLocation
sl, Lexeme
_) <- Lexeme -> Parser LexemeStep
lexeme Lexeme
Lexeme'OpenParen
  [TokenStep]
elems <- Parser TokenStep -> Parser [TokenStep]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser TokenStep
sugarParse
  Parser LexemeStep -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser LexemeStep -> Parser ()) -> Parser LexemeStep -> Parser ()
forall a b. (a -> b) -> a -> b
$ Lexeme -> Parser LexemeStep
lexeme Lexeme
Lexeme'CloseParen
  TokenNote
note <- Parser TokenNote
sugarParseNote
  let tkn :: Token
tkn = [TokenStep] -> Wrap -> TokenNote -> Token
Token'List [TokenStep]
elems Wrap
Wrap'Paren TokenNote
note
  TokenStep -> Parser TokenStep
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceLocation
sl, Token
tkn)

sugarParseQuote :: Parser TokenStep
sugarParseQuote :: Parser TokenStep
sugarParseQuote = do
  (SourceLocation
sl, Lexeme
_) <- Lexeme -> Parser LexemeStep
lexeme Lexeme
Lexeme'QuoteStart
  String
s <- Parser String
lexemeQuoteString
  Parser LexemeStep -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser LexemeStep -> Parser ()) -> Parser LexemeStep -> Parser ()
forall a b. (a -> b) -> a -> b
$ Lexeme -> Parser LexemeStep
lexeme Lexeme
Lexeme'QuoteEnd
  TokenNote
note <- Parser TokenNote
sugarParseNote
  let tkn :: Token
tkn = String -> TokenNote -> Token
Token'Text String
s TokenNote
note
  TokenStep -> Parser TokenStep
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceLocation
sl, Token
tkn)

sugarParseText :: Parser TokenStep
sugarParseText :: Parser TokenStep
sugarParseText = do
  (SourceLocation
sl, Lexeme
_) <- Lexeme -> Parser LexemeStep
lexeme Lexeme
Lexeme'StringStart
  String
s <- Parser String
lexemeString
  TokenNote
note <- Parser TokenNote
sugarParseNote
  let tkn :: Token
tkn = String -> TokenNote -> Token
Token'Text String
s TokenNote
note
  TokenStep -> Parser TokenStep
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceLocation
sl, Token
tkn)

lexemeQuoteString :: Parser String
lexemeQuoteString :: Parser String
lexemeQuoteString = ([LexemeStep] -> ([LexemeStep], Either ParseError String))
-> Parser String
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError String))
 -> Parser String)
-> ([LexemeStep] -> ([LexemeStep], Either ParseError String))
-> Parser String
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> case [LexemeStep]
ts of
  [] -> ([LexemeStep]
ts, ParseError -> Either ParseError String
forall a b. a -> Either a b
Left (Maybe SourceLocation
forall a. Maybe a
Nothing, String
"lexemeQuoteString end"))
  (LexemeStep
x:[LexemeStep]
xs) -> case LexemeStep -> Lexeme
forall a b. (a, b) -> b
snd LexemeStep
x of
    Lexeme'QuotedString String
s -> ([LexemeStep]
xs, String -> Either ParseError String
forall a b. b -> Either a b
Right String
s)
    Lexeme
_ -> ([LexemeStep]
xs, ParseError -> Either ParseError String
forall a b. a -> Either a b
Left (SourceLocation -> Maybe SourceLocation
forall a. a -> Maybe a
Just (SourceLocation -> Maybe SourceLocation)
-> SourceLocation -> Maybe SourceLocation
forall a b. (a -> b) -> a -> b
$ LexemeStep -> SourceLocation
forall a b. (a, b) -> a
fst LexemeStep
x, String
"lexemeQuoteString none"))

lexemeString :: Parser String
lexemeString :: Parser String
lexemeString = ([LexemeStep] -> ([LexemeStep], Either ParseError String))
-> Parser String
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError String))
 -> Parser String)
-> ([LexemeStep] -> ([LexemeStep], Either ParseError String))
-> Parser String
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> case [LexemeStep]
ts of
  [] -> ([LexemeStep]
ts, ParseError -> Either ParseError String
forall a b. a -> Either a b
Left (Maybe SourceLocation
forall a. Maybe a
Nothing, String
"lexemeString end"))
  (LexemeStep
x:[LexemeStep]
xs) -> case LexemeStep -> Lexeme
forall a b. (a, b) -> b
snd LexemeStep
x of
    Lexeme'String String
s -> ([LexemeStep]
xs, String -> Either ParseError String
forall a b. b -> Either a b
Right String
s)
    Lexeme
_ -> ([LexemeStep]
xs, ParseError -> Either ParseError String
forall a b. a -> Either a b
Left (SourceLocation -> Maybe SourceLocation
forall a. a -> Maybe a
Just (SourceLocation -> Maybe SourceLocation)
-> SourceLocation -> Maybe SourceLocation
forall a b. (a -> b) -> a -> b
$ LexemeStep -> SourceLocation
forall a b. (a, b) -> a
fst LexemeStep
x, String
"lexemeString none"))

lexeme :: Lexeme -> Parser LexemeStep
lexeme :: Lexeme -> Parser LexemeStep
lexeme Lexeme
t = ([LexemeStep] -> ([LexemeStep], Either ParseError LexemeStep))
-> Parser LexemeStep
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError LexemeStep))
 -> Parser LexemeStep)
-> ([LexemeStep] -> ([LexemeStep], Either ParseError LexemeStep))
-> Parser LexemeStep
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> case [LexemeStep]
ts of
  [] -> ([LexemeStep]
ts, ParseError -> Either ParseError LexemeStep
forall a b. a -> Either a b
Left (Maybe SourceLocation
forall a. Maybe a
Nothing, String
"lexeme none"))
  (LexemeStep
x:[LexemeStep]
xs) -> if Lexeme
t Lexeme -> Lexeme -> Bool
forall a. Eq a => a -> a -> Bool
== (LexemeStep -> Lexeme
forall a b. (a, b) -> b
snd LexemeStep
x) then ([LexemeStep]
xs, LexemeStep -> Either ParseError LexemeStep
forall a b. b -> Either a b
Right LexemeStep
x) else ([LexemeStep]
xs, ParseError -> Either ParseError LexemeStep
forall a b. a -> Either a b
Left (SourceLocation -> Maybe SourceLocation
forall a. a -> Maybe a
Just (SourceLocation -> Maybe SourceLocation)
-> SourceLocation -> Maybe SourceLocation
forall a b. (a -> b) -> a -> b
$ LexemeStep -> SourceLocation
forall a b. (a, b) -> a
fst LexemeStep
x, String
"lexeme no match"))

peek :: Parser LexemeStep
peek :: Parser LexemeStep
peek = ([LexemeStep] -> ([LexemeStep], Either ParseError LexemeStep))
-> Parser LexemeStep
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError LexemeStep))
 -> Parser LexemeStep)
-> ([LexemeStep] -> ([LexemeStep], Either ParseError LexemeStep))
-> Parser LexemeStep
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> case [LexemeStep]
ts of
  [] -> ([LexemeStep]
ts, ParseError -> Either ParseError LexemeStep
forall a b. a -> Either a b
Left (Maybe SourceLocation
forall a. Maybe a
Nothing, String
"peek"))
  (LexemeStep
x:[LexemeStep]
_) -> ([LexemeStep]
ts, LexemeStep -> Either ParseError LexemeStep
forall a b. b -> Either a b
Right (LexemeStep -> Either ParseError LexemeStep)
-> LexemeStep -> Either ParseError LexemeStep
forall a b. (a -> b) -> a -> b
$ LexemeStep
x)

tryPeek :: Parser (Maybe LexemeStep)
tryPeek :: Parser (Maybe LexemeStep)
tryPeek = ([LexemeStep]
 -> ([LexemeStep], Either ParseError (Maybe LexemeStep)))
-> Parser (Maybe LexemeStep)
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep]
  -> ([LexemeStep], Either ParseError (Maybe LexemeStep)))
 -> Parser (Maybe LexemeStep))
-> ([LexemeStep]
    -> ([LexemeStep], Either ParseError (Maybe LexemeStep)))
-> Parser (Maybe LexemeStep)
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> case [LexemeStep]
ts of
  [] -> ([LexemeStep]
ts, Maybe LexemeStep -> Either ParseError (Maybe LexemeStep)
forall a b. b -> Either a b
Right Maybe LexemeStep
forall a. Maybe a
Nothing)
  (LexemeStep
x:[LexemeStep]
_) -> ([LexemeStep]
ts, Maybe LexemeStep -> Either ParseError (Maybe LexemeStep)
forall a b. b -> Either a b
Right (Maybe LexemeStep -> Either ParseError (Maybe LexemeStep))
-> Maybe LexemeStep -> Either ParseError (Maybe LexemeStep)
forall a b. (a -> b) -> a -> b
$ LexemeStep -> Maybe LexemeStep
forall a. a -> Maybe a
Just LexemeStep
x)

nextLexeme :: Parser LexemeStep
nextLexeme :: Parser LexemeStep
nextLexeme = ([LexemeStep] -> ([LexemeStep], Either ParseError LexemeStep))
-> Parser LexemeStep
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError LexemeStep))
 -> Parser LexemeStep)
-> ([LexemeStep] -> ([LexemeStep], Either ParseError LexemeStep))
-> Parser LexemeStep
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> case [LexemeStep]
ts of
  [] -> ([], ParseError -> Either ParseError LexemeStep
forall a b. a -> Either a b
Left (Maybe SourceLocation
forall a. Maybe a
Nothing, String
"nextLexeme"))
  (LexemeStep
x:[LexemeStep]
xs) -> ([LexemeStep]
xs, LexemeStep -> Either ParseError LexemeStep
forall a b. b -> Either a b
Right LexemeStep
x)

between :: Applicative m => m open -> m close -> m a -> m a
between :: m open -> m close -> m a -> m a
between m open
open m close
close m a
p = m open
open m open -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
p m a -> m close -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m close
close

try :: Parser a -> Parser a
try :: Parser a -> Parser a
try Parser a
p = ([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
forall a.
([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a
Parser (([LexemeStep] -> ([LexemeStep], Either ParseError a)) -> Parser a)
-> ([LexemeStep] -> ([LexemeStep], Either ParseError a))
-> Parser a
forall a b. (a -> b) -> a -> b
$ \[LexemeStep]
ts -> case Parser a -> [LexemeStep] -> ([LexemeStep], Either ParseError a)
forall a.
Parser a -> [LexemeStep] -> ([LexemeStep], Either ParseError a)
runParser Parser a
p [LexemeStep]
ts of
  ([LexemeStep]
_, Left ParseError
a) -> ([LexemeStep]
ts, ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
a)
  ([LexemeStep]
ts', Right a
b)  -> ([LexemeStep]
ts', a -> Either ParseError a
forall a b. b -> Either a b
Right a
b)