{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE OrPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}

module Elara.Lexer.Utils (
    LexMonad,
    ParseState (),
    AlexInput (),
    LexerError (..),
    getPosition,
    stringBuf,
    lexSC,
    commentDepth,
    pendingPosition,
    input,
    pendingTokens,
    position,
    rest,
    cleanIndentation,
    createRegionStartingAt,
    emitAt,
    createRegion,
    splitQualName,
    startWhite,
    alexGetByte,
    initialLexState,
    triggerIndentLayout,
    triggerBlockLayout,
    checkBlockLayout,
) where

import Codec.Binary.UTF8.String (encodeChar)
import Data.Char
import Data.Kind (Type)
import Data.List.NonEmpty (span, (<|))
import Data.Text qualified as T
import Elara.AST.Name (ModuleName (..))
import Elara.AST.Region (Located (Located), RealPosition (..), RealSourceRegion (..), SourceRegion (..), mkSourceRegionIn, positionToDiagnosePosition)
import Elara.Error
import Elara.Error.Codes qualified as Codes
import Elara.Lexer.Token (Lexeme, TokPosition, Token (..), tokenEndsExpr)
import Error.Diagnose (Marker (..), Note (..), Report (Err))

import Effectful (Eff)
import Effectful.Error.Static
import Effectful.State.Extra (use', (%=), (.=))
import Effectful.State.Static.Local
import Elara.Data.Pretty (Pretty)
import Elara.Logging (StructuredDebug)
import Prelude hiding (span)

data AlexInput = AlexInput
    { AlexInput -> FilePath
_filePath :: FilePath
    , AlexInput -> Char
_prev :: Char
    , AlexInput -> [Word8]
_bytes :: [Word8]
    , AlexInput -> Text
_rest :: Text
    , AlexInput -> RealPosition
_position :: RealPosition
    }
    deriving (Int -> AlexInput -> ShowS
[AlexInput] -> ShowS
AlexInput -> FilePath
(Int -> AlexInput -> ShowS)
-> (AlexInput -> FilePath)
-> ([AlexInput] -> ShowS)
-> Show AlexInput
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AlexInput -> ShowS
showsPrec :: Int -> AlexInput -> ShowS
$cshow :: AlexInput -> FilePath
show :: AlexInput -> FilePath
$cshowList :: [AlexInput] -> ShowS
showList :: [AlexInput] -> ShowS
Show, (forall x. AlexInput -> Rep AlexInput x)
-> (forall x. Rep AlexInput x -> AlexInput) -> Generic AlexInput
forall x. Rep AlexInput x -> AlexInput
forall x. AlexInput -> Rep AlexInput x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AlexInput -> Rep AlexInput x
from :: forall x. AlexInput -> Rep AlexInput x
$cto :: forall x. Rep AlexInput x -> AlexInput
to :: forall x. Rep AlexInput x -> AlexInput
Generic)
instance Pretty AlexInput

data IndentInfo = IndentInfo
    { IndentInfo -> Int
_indent :: Int
    , IndentInfo -> RealPosition
_indentPos :: RealPosition
    , IndentInfo -> Int
_openedAtDepth :: Int
    -- ^ the delimDepth when this indent was opened
    }
    deriving (Int -> IndentInfo -> ShowS
[IndentInfo] -> ShowS
IndentInfo -> FilePath
(Int -> IndentInfo -> ShowS)
-> (IndentInfo -> FilePath)
-> ([IndentInfo] -> ShowS)
-> Show IndentInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IndentInfo -> ShowS
showsPrec :: Int -> IndentInfo -> ShowS
$cshow :: IndentInfo -> FilePath
show :: IndentInfo -> FilePath
$cshowList :: [IndentInfo] -> ShowS
showList :: [IndentInfo] -> ShowS
Show, (forall x. IndentInfo -> Rep IndentInfo x)
-> (forall x. Rep IndentInfo x -> IndentInfo) -> Generic IndentInfo
forall x. Rep IndentInfo x -> IndentInfo
forall x. IndentInfo -> Rep IndentInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IndentInfo -> Rep IndentInfo x
from :: forall x. IndentInfo -> Rep IndentInfo x
$cto :: forall x. Rep IndentInfo x -> IndentInfo
to :: forall x. Rep IndentInfo x -> IndentInfo
Generic)

instance Pretty IndentInfo

data ParseState = ParseState
    { ParseState -> AlexInput
_input :: AlexInput
    , ParseState -> Int
_lexSC :: Int
    -- ^ lexer start code
    , ParseState -> Text
_stringBuf :: Text
    -- ^ temporary storage for strings
    , ParseState -> [Lexeme]
_pendingTokens :: [Lexeme]
    -- ^ right now used when Parser consumes the lookahead and decided to put it back
    , ParseState -> NonEmpty IndentInfo
_indentStack :: NonEmpty IndentInfo
    -- ^ stack of indentation levels
    , ParseState -> RealPosition
_pendingPosition :: TokPosition
    -- ^ needed when parsing strings, chars, multi-line strings
    , ParseState -> Bool
_prevEndsExpr :: Bool
    -- ^ did the previous token end an expression? (used for offside rule)
    , ParseState -> Int
_delimDepth :: Int
    -- ^ current depth of open delimiters ((), [], {
    , ParseState -> Int
_commentDepth :: Int
    -- ^ nested comment depth
    , ParseState -> Maybe LayoutExpectation
_layoutExpected :: Maybe LayoutExpectation
    -- ^ Tracks if the previous token triggers a layout block
    }
    deriving (Int -> ParseState -> ShowS
[ParseState] -> ShowS
ParseState -> FilePath
(Int -> ParseState -> ShowS)
-> (ParseState -> FilePath)
-> ([ParseState] -> ShowS)
-> Show ParseState
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseState -> ShowS
showsPrec :: Int -> ParseState -> ShowS
$cshow :: ParseState -> FilePath
show :: ParseState -> FilePath
$cshowList :: [ParseState] -> ShowS
showList :: [ParseState] -> ShowS
Show, (forall x. ParseState -> Rep ParseState x)
-> (forall x. Rep ParseState x -> ParseState) -> Generic ParseState
forall x. Rep ParseState x -> ParseState
forall x. ParseState -> Rep ParseState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ParseState -> Rep ParseState x
from :: forall x. ParseState -> Rep ParseState x
$cto :: forall x. Rep ParseState x -> ParseState
to :: forall x. Rep ParseState x -> ParseState
Generic)

instance Pretty ParseState

data LayoutExpectation
    = -- | Just checks alignment (like match/with)
      ExpectIndent
    | -- | Starts a new block at the next token (let/where/do)
      ExpectBlock
    deriving (LayoutExpectation -> LayoutExpectation -> Bool
(LayoutExpectation -> LayoutExpectation -> Bool)
-> (LayoutExpectation -> LayoutExpectation -> Bool)
-> Eq LayoutExpectation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LayoutExpectation -> LayoutExpectation -> Bool
== :: LayoutExpectation -> LayoutExpectation -> Bool
$c/= :: LayoutExpectation -> LayoutExpectation -> Bool
/= :: LayoutExpectation -> LayoutExpectation -> Bool
Eq, Int -> LayoutExpectation -> ShowS
[LayoutExpectation] -> ShowS
LayoutExpectation -> FilePath
(Int -> LayoutExpectation -> ShowS)
-> (LayoutExpectation -> FilePath)
-> ([LayoutExpectation] -> ShowS)
-> Show LayoutExpectation
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LayoutExpectation -> ShowS
showsPrec :: Int -> LayoutExpectation -> ShowS
$cshow :: LayoutExpectation -> FilePath
show :: LayoutExpectation -> FilePath
$cshowList :: [LayoutExpectation] -> ShowS
showList :: [LayoutExpectation] -> ShowS
Show, (forall x. LayoutExpectation -> Rep LayoutExpectation x)
-> (forall x. Rep LayoutExpectation x -> LayoutExpectation)
-> Generic LayoutExpectation
forall x. Rep LayoutExpectation x -> LayoutExpectation
forall x. LayoutExpectation -> Rep LayoutExpectation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LayoutExpectation -> Rep LayoutExpectation x
from :: forall x. LayoutExpectation -> Rep LayoutExpectation x
$cto :: forall x. Rep LayoutExpectation x -> LayoutExpectation
to :: forall x. Rep LayoutExpectation x -> LayoutExpectation
Generic)
instance Pretty LayoutExpectation

makeLenses ''AlexInput
makeLenses ''IndentInfo
makeLenses ''ParseState

type LexMonad :: Type -> Type
type LexMonad a = Eff '[State ParseState, Error LexerError, StructuredDebug] a

setPrevEndsExpr :: Bool -> LexMonad ()
setPrevEndsExpr :: Bool -> LexMonad ()
setPrevEndsExpr Bool
b = (ParseState -> ParseState) -> LexMonad ()
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
modify (\ParseState
st -> ParseState
st{_prevEndsExpr = b})

getPrevEndsExpr :: LexMonad Bool
getPrevEndsExpr :: LexMonad Bool
getPrevEndsExpr = (ParseState -> Bool) -> LexMonad Bool
forall s (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, State s :> es) =>
(s -> a) -> Eff es a
gets ParseState -> Bool
_prevEndsExpr

mkIndentInfo :: Int -> LexMonad IndentInfo
mkIndentInfo :: Int -> LexMonad IndentInfo
mkIndentInfo Int
i = do
    pos <- Lens' ParseState RealPosition
-> Eff
     '[State ParseState, Error LexerError, StructuredDebug] RealPosition
forall k a (r :: [(* -> *) -> * -> *]) (is :: IxList) b.
(Is k A_Getter, State a :> r) =>
Optic' k is a b -> Eff r b
use' (Lens' ParseState AlexInput
input Lens' ParseState AlexInput
-> Lens' AlexInput RealPosition -> Lens' ParseState RealPosition
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' AlexInput RealPosition
position)
    d <- use' delimDepth
    pure (IndentInfo i pos d)

data LexerError
    = -- | When an element is indented more than expected
      TooMuchIndentation
        -- | The expected indentation
        IndentInfo
        -- | The potential further indentation
        (Maybe IndentInfo)
        -- | The actual indentation
        Int
        -- | The current state of the lexer
        ParseState
    | UnterminatedStringLiteral ParseState
    | GenericAlexError AlexInput
    deriving (Int -> LexerError -> ShowS
[LexerError] -> ShowS
LexerError -> FilePath
(Int -> LexerError -> ShowS)
-> (LexerError -> FilePath)
-> ([LexerError] -> ShowS)
-> Show LexerError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LexerError -> ShowS
showsPrec :: Int -> LexerError -> ShowS
$cshow :: LexerError -> FilePath
show :: LexerError -> FilePath
$cshowList :: [LexerError] -> ShowS
showList :: [LexerError] -> ShowS
Show, (forall x. LexerError -> Rep LexerError x)
-> (forall x. Rep LexerError x -> LexerError) -> Generic LexerError
forall x. Rep LexerError x -> LexerError
forall x. LexerError -> Rep LexerError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LexerError -> Rep LexerError x
from :: forall x. LexerError -> Rep LexerError x
$cto :: forall x. Rep LexerError x -> LexerError
to :: forall x. Rep LexerError x -> LexerError
Generic)

instance Pretty LexerError

instance ReportableError LexerError where
    errorCode :: LexerError -> Maybe ErrorCode
errorCode (TooMuchIndentation{}) = ErrorCode -> Maybe ErrorCode
forall a. a -> Maybe a
Just Doc ann
ErrorCode
Codes.tooMuchIndentation
    errorCode (UnterminatedStringLiteral ParseState
_) = ErrorCode -> Maybe ErrorCode
forall a. a -> Maybe a
Just Doc ann
ErrorCode
Codes.unterminatedStringLiteral
    errorCode (GenericAlexError AlexInput
_) = ErrorCode -> Maybe ErrorCode
forall a. a -> Maybe a
Just Doc ann
ErrorCode
Codes.genericLexicalError

    getReport :: LexerError -> Maybe (Report (Doc AnsiStyle))
getReport (TooMuchIndentation IndentInfo
expected Maybe IndentInfo
further Int
actual ParseState
s) = do
        let fp :: FilePath
fp = Optic' A_Lens NoIx ParseState FilePath -> ParseState -> FilePath
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' ParseState AlexInput
input Lens' ParseState AlexInput
-> Lens' AlexInput FilePath
-> Optic' A_Lens NoIx ParseState FilePath
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' AlexInput FilePath
filePath) ParseState
s
        let pos :: RealPosition
pos = Lens' ParseState RealPosition -> ParseState -> RealPosition
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' ParseState AlexInput
input Lens' ParseState AlexInput
-> Lens' AlexInput RealPosition -> Lens' ParseState RealPosition
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' AlexInput RealPosition
position) ParseState
s
        let msg :: Doc AnsiStyle
msg = Doc AnsiStyle
"Unexpected change in indentation. Expected " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle
forall b a. (Show a, IsString b) => a -> b
show (IndentInfo
expected IndentInfo -> Lens' IndentInfo Int -> Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' IndentInfo Int
indent) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
" spaces, but got " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle
forall b a. (Show a, IsString b) => a -> b
show Int
actual Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
" spaces."
        let hint :: Doc AnsiStyle
hint = case Maybe IndentInfo
further of
                Maybe IndentInfo
Nothing -> Doc AnsiStyle
"Try removing the extra indentation."
                Just IndentInfo
f -> Doc AnsiStyle
"Try removing the extra indentation or indenting the line by " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle
forall b a. (Show a, IsString b) => a -> b
show (IndentInfo
f IndentInfo -> Lens' IndentInfo Int -> Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' IndentInfo Int
indent Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
actual) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
" space(s)."

        let baseHints :: [(Position, Marker (Doc AnsiStyle))]
baseHints =
                [ (FilePath -> RealPosition -> Position
positionToDiagnosePosition FilePath
fp RealPosition
pos, Doc AnsiStyle -> Marker (Doc AnsiStyle)
forall msg. msg -> Marker msg
This Doc AnsiStyle
"this line is indented incorrectly")
                , (FilePath -> RealPosition -> Position
positionToDiagnosePosition FilePath
fp (IndentInfo
expected IndentInfo -> Lens' IndentInfo RealPosition -> RealPosition
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' IndentInfo RealPosition
indentPos), Doc AnsiStyle -> Marker (Doc AnsiStyle)
forall msg. msg -> Marker msg
Maybe Doc AnsiStyle
"If the decrease in indentation is intentional, the problematic line should line up with this line.")
                ]
        let furtherHints :: [(Position, Marker (Doc AnsiStyle))]
furtherHints = case Maybe IndentInfo
further of
                Maybe IndentInfo
Nothing -> [(Position, Marker (Doc AnsiStyle))]
baseHints
                Just IndentInfo
f -> (FilePath -> RealPosition -> Position
positionToDiagnosePosition FilePath
fp (IndentInfo
f IndentInfo -> Lens' IndentInfo RealPosition -> RealPosition
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' IndentInfo RealPosition
indentPos), Doc AnsiStyle -> Marker (Doc AnsiStyle)
forall msg. msg -> Marker msg
Maybe (Doc AnsiStyle
"an offside rule begins here (column " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle
forall b a. (Show a, IsString b) => a -> b
show (IndentInfo
f IndentInfo -> Lens' IndentInfo Int -> Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' IndentInfo Int
indent) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"). If you think the problematic line is \"related\" to this line, make sure they line up.")) (Position, Marker (Doc AnsiStyle))
-> [(Position, Marker (Doc AnsiStyle))]
-> [(Position, Marker (Doc AnsiStyle))]
forall a. a -> [a] -> [a]
: [(Position, Marker (Doc AnsiStyle))]
baseHints

        Report (Doc AnsiStyle) -> Maybe (Report (Doc AnsiStyle))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Report (Doc AnsiStyle) -> Maybe (Report (Doc AnsiStyle)))
-> Report (Doc AnsiStyle) -> Maybe (Report (Doc AnsiStyle))
forall a b. (a -> b) -> a -> b
$
            Maybe (Doc AnsiStyle)
-> Doc AnsiStyle
-> [(Position, Marker (Doc AnsiStyle))]
-> [Note (Doc AnsiStyle)]
-> Report (Doc AnsiStyle)
forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
Err
                (Doc AnsiStyle -> Maybe (Doc AnsiStyle)
forall a. a -> Maybe a
Just Doc AnsiStyle
ErrorCode
Codes.tooMuchIndentation)
                Doc AnsiStyle
msg
                [(Position, Marker (Doc AnsiStyle))]
furtherHints
                [ Doc AnsiStyle -> Note (Doc AnsiStyle)
forall msg. msg -> Note msg
Note Doc AnsiStyle
"When using lightweight syntax, the level of indentation is very important. Currently, I can't tell what expression this line is supposed to be a part of as it doesn't line up with anything, and didn't appear in a place where indentation can begin."
                , Doc AnsiStyle -> Note (Doc AnsiStyle)
forall msg. msg -> Note msg
Hint Doc AnsiStyle
hint
                ]
    getReport (GenericAlexError AlexInput
ai) = do
        let fp :: FilePath
fp = Lens' AlexInput FilePath -> AlexInput -> FilePath
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' AlexInput FilePath
filePath AlexInput
ai
        let pos :: RealPosition
pos = Lens' AlexInput RealPosition -> AlexInput -> RealPosition
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' AlexInput RealPosition
position AlexInput
ai
        let msg :: Doc AnsiStyle
msg = Doc AnsiStyle
"Lexical error"

        Report (Doc AnsiStyle) -> Maybe (Report (Doc AnsiStyle))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Report (Doc AnsiStyle) -> Maybe (Report (Doc AnsiStyle)))
-> Report (Doc AnsiStyle) -> Maybe (Report (Doc AnsiStyle))
forall a b. (a -> b) -> a -> b
$
            Maybe (Doc AnsiStyle)
-> Doc AnsiStyle
-> [(Position, Marker (Doc AnsiStyle))]
-> [Note (Doc AnsiStyle)]
-> Report (Doc AnsiStyle)
forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
Err
                (Doc AnsiStyle -> Maybe (Doc AnsiStyle)
forall a. a -> Maybe a
Just Doc AnsiStyle
ErrorCode
Codes.genericLexicalError)
                Doc AnsiStyle
msg
                [(FilePath -> RealPosition -> Position
positionToDiagnosePosition FilePath
fp RealPosition
pos, Doc AnsiStyle -> Marker (Doc AnsiStyle)
forall msg. msg -> Marker msg
This Doc AnsiStyle
"lexical error occurred here")]
                [ Doc AnsiStyle -> Note (Doc AnsiStyle)
forall msg. msg -> Note msg
Note Doc AnsiStyle
"The lexer encountered an invalid character or sequence of characters that it could not process."
                ]
    getReport (UnterminatedStringLiteral ParseState
s) = do
        let fp :: FilePath
fp = Optic' A_Lens NoIx ParseState FilePath -> ParseState -> FilePath
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' ParseState AlexInput
input Lens' ParseState AlexInput
-> Lens' AlexInput FilePath
-> Optic' A_Lens NoIx ParseState FilePath
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' AlexInput FilePath
filePath) ParseState
s
        let pos :: RealPosition
pos = Lens' ParseState RealPosition -> ParseState -> RealPosition
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' ParseState AlexInput
input Lens' ParseState AlexInput
-> Lens' AlexInput RealPosition -> Lens' ParseState RealPosition
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' AlexInput RealPosition
position) ParseState
s
        let msg :: Doc AnsiStyle
msg = Doc AnsiStyle
"Unterminated string literal."
        let hint :: Doc AnsiStyle
hint = Doc AnsiStyle
"Make sure that the string literal is terminated with a double quote (\")."
        Report (Doc AnsiStyle) -> Maybe (Report (Doc AnsiStyle))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Report (Doc AnsiStyle) -> Maybe (Report (Doc AnsiStyle)))
-> Report (Doc AnsiStyle) -> Maybe (Report (Doc AnsiStyle))
forall a b. (a -> b) -> a -> b
$
            Maybe (Doc AnsiStyle)
-> Doc AnsiStyle
-> [(Position, Marker (Doc AnsiStyle))]
-> [Note (Doc AnsiStyle)]
-> Report (Doc AnsiStyle)
forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
Err
                (Doc AnsiStyle -> Maybe (Doc AnsiStyle)
forall a. a -> Maybe a
Just Doc AnsiStyle
ErrorCode
Codes.unterminatedStringLiteral)
                Doc AnsiStyle
msg
                [(FilePath -> RealPosition -> Position
positionToDiagnosePosition FilePath
fp RealPosition
pos, Doc AnsiStyle -> Marker (Doc AnsiStyle)
forall msg. msg -> Marker msg
This Doc AnsiStyle
"this string literal is unterminated")]
                [ Doc AnsiStyle -> Note (Doc AnsiStyle)
forall msg. msg -> Note msg
Note Doc AnsiStyle
"String literals are delimited by double quotes (\")."
                , Doc AnsiStyle -> Note (Doc AnsiStyle)
forall msg. msg -> Note msg
Hint Doc AnsiStyle
hint
                ]

initialLexState :: FilePath -> Text -> ParseState
initialLexState :: FilePath -> Text -> ParseState
initialLexState FilePath
fp Text
s =
    ParseState
        { _input :: AlexInput
_input =
            AlexInput
                { _filePath :: FilePath
_filePath = FilePath
fp
                , _prev :: Char
_prev = Char
'\n'
                , _bytes :: [Word8]
_bytes = []
                , _rest :: Text
_rest = Text
s
                , _position :: RealPosition
_position = Int -> Int -> RealPosition
Position Int
1 Int
1
                }
        , _lexSC :: Int
_lexSC = Int
0
        , _stringBuf :: Text
_stringBuf = Text
""
        , _pendingTokens :: [Lexeme]
_pendingTokens = []
        , _indentStack :: NonEmpty IndentInfo
_indentStack =
            Int -> RealPosition -> Int -> IndentInfo
IndentInfo
                Int
0
                (Int -> Int -> RealPosition
Position Int
1 Int
1)
                Int
0
                IndentInfo -> [IndentInfo] -> NonEmpty IndentInfo
forall a. a -> [a] -> NonEmpty a
:| []
        , _pendingPosition :: RealPosition
_pendingPosition = Int -> Int -> RealPosition
Position Int
1 Int
1
        , _prevEndsExpr :: Bool
_prevEndsExpr = Bool
True
        , _delimDepth :: Int
_delimDepth = Int
0
        , _commentDepth :: Int
_commentDepth = Int
0
        , _layoutExpected :: Maybe LayoutExpectation
_layoutExpected = Maybe LayoutExpectation
forall a. Maybe a
Nothing
        }

pushFront :: Lexeme -> LexMonad ()
pushFront :: Lexeme -> LexMonad ()
pushFront Lexeme
lex = (ParseState -> ParseState) -> LexMonad ()
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
modify (Lens' ParseState [Lexeme]
-> ([Lexeme] -> [Lexeme]) -> ParseState -> ParseState
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Lens' ParseState [Lexeme]
pendingTokens (Lexeme
lex Lexeme -> [Lexeme] -> [Lexeme]
forall a. a -> [a] -> [a]
:))

pushBack :: Lexeme -> LexMonad ()
pushBack :: Lexeme -> LexMonad ()
pushBack Lexeme
lex = (ParseState -> ParseState) -> LexMonad ()
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
modify (Lens' ParseState [Lexeme]
-> ([Lexeme] -> [Lexeme]) -> ParseState -> ParseState
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Lens' ParseState [Lexeme]
pendingTokens (\[Lexeme]
toks -> [Lexeme]
toks [Lexeme] -> [Lexeme] -> [Lexeme]
forall a. Semigroup a => a -> a -> a
<> [Lexeme
lex]))

triggerIndentLayout :: LexMonad ()
triggerIndentLayout :: LexMonad ()
triggerIndentLayout =
    Lens' ParseState (Maybe LayoutExpectation)
layoutExpected Lens' ParseState (Maybe LayoutExpectation)
-> Maybe LayoutExpectation -> LexMonad ()
forall k s (r :: [(* -> *) -> * -> *]) (is :: IxList) a b.
(Is k A_Setter, State s :> r) =>
Optic k is s s a b -> b -> Eff r ()
.= LayoutExpectation -> Maybe LayoutExpectation
forall a. a -> Maybe a
Just LayoutExpectation
ExpectIndent

triggerBlockLayout :: LexMonad ()
triggerBlockLayout :: LexMonad ()
triggerBlockLayout = Lens' ParseState (Maybe LayoutExpectation)
layoutExpected Lens' ParseState (Maybe LayoutExpectation)
-> Maybe LayoutExpectation -> LexMonad ()
forall k s (r :: [(* -> *) -> * -> *]) (is :: IxList) a b.
(Is k A_Setter, State s :> r) =>
Optic k is s s a b -> b -> Eff r ()
.= LayoutExpectation -> Maybe LayoutExpectation
forall a. a -> Maybe a
Just LayoutExpectation
ExpectBlock

{- | If a (block) layout is expected, check the current token's indentation against the top of the stack,
and insert an INDENT token if necessary
-}
checkBlockLayout :: Int -> LexMonad ()
checkBlockLayout :: Int -> LexMonad ()
checkBlockLayout Int
tokenLen = do
    m <- Lens' ParseState (Maybe LayoutExpectation)
-> Eff
     '[State ParseState, Error LexerError, StructuredDebug]
     (Maybe LayoutExpectation)
forall k a (r :: [(* -> *) -> * -> *]) (is :: IxList) b.
(Is k A_Getter, State a :> r) =>
Optic' k is a b -> Eff r b
use' Lens' ParseState (Maybe LayoutExpectation)
layoutExpected
    case m of
        Just LayoutExpectation
ExpectBlock -> do
            pos@(Position _ col) <- Int
-> Eff
     '[State ParseState, Error LexerError, StructuredDebug] RealPosition
getPosition Int
tokenLen

            indentInfo <- mkIndentInfo (col - 1)
            indentStack %= (indentInfo <|)

            -- push a virtual indent token before the current token
            r <- createRegion pos pos
            pushFront (Located (RealSourceRegion r) TokenIndent)

            -- reset
            layoutExpected .= Nothing
        Maybe LayoutExpectation
_ -> LexMonad ()
forall (f :: * -> *). Applicative f => f ()
pass

-- Emits a token, updating the prevEndsExpr state if necessary
emitAt :: Token -> SourceRegion -> LexMonad (Maybe Lexeme)
emitAt :: Token -> SourceRegion -> LexMonad (Maybe Lexeme)
emitAt Token
t SourceRegion
region = do
    Lens' ParseState (Maybe LayoutExpectation)
layoutExpected Lens' ParseState (Maybe LayoutExpectation)
-> Maybe LayoutExpectation -> LexMonad ()
forall k s (r :: [(* -> *) -> * -> *]) (is :: IxList) a b.
(Is k A_Setter, State s :> r) =>
Optic k is s s a b -> b -> Eff r ()
.= Maybe LayoutExpectation
forall a. Maybe a
Nothing -- reset layout expectation
    prevEnds <- LexMonad Bool
getPrevEndsExpr
    -- Suppress LINESEP if previous token cannot end an expression
    case t of
        Token
TokenLeftParen; Token
TokenLeftBracket; Token
TokenLeftBrace -> (ParseState -> ParseState) -> LexMonad ()
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
modify (Lens' ParseState Int
delimDepth Lens' ParseState Int -> (Int -> Int) -> ParseState -> ParseState
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) LexMonad () -> LexMonad (Maybe Lexeme) -> LexMonad (Maybe Lexeme)
forall a b.
Eff '[State ParseState, Error LexerError, StructuredDebug] a
-> Eff '[State ParseState, Error LexerError, StructuredDebug] b
-> Eff '[State ParseState, Error LexerError, StructuredDebug] b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LexMonad (Maybe Lexeme)
emit
        Token
TokenRightParen; Token
TokenRightBracket; Token
TokenRightBrace -> Token -> SourceRegion -> LexMonad (Maybe Lexeme)
emitCloser Token
t SourceRegion
region
        Token
TokenLineSeparator | Bool -> Bool
not Bool
prevEnds -> do
            Maybe Lexeme -> LexMonad (Maybe Lexeme)
forall a.
a -> Eff '[State ParseState, Error LexerError, StructuredDebug] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Lexeme
forall a. Maybe a
Nothing
        Token
_ -> LexMonad (Maybe Lexeme)
emit
  where
    emit :: LexMonad (Maybe Lexeme)
emit = do
        Bool -> LexMonad ()
setPrevEndsExpr (Token -> Bool
tokenEndsExpr Token
t)
        let lex :: Lexeme
lex = SourceRegion -> Token -> Lexeme
forall a. SourceRegion -> a -> Located a
Located SourceRegion
region Token
t
        pending <- Lens' ParseState [Lexeme]
-> Eff
     '[State ParseState, Error LexerError, StructuredDebug] [Lexeme]
forall k a (r :: [(* -> *) -> * -> *]) (is :: IxList) b.
(Is k A_Getter, State a :> r) =>
Optic' k is a b -> Eff r b
use' Lens' ParseState [Lexeme]
pendingTokens
        if null pending
            then pure (Just lex)
            else do
                pushBack lex
                pure Nothing

popPending :: LexMonad (Maybe Lexeme)
popPending :: LexMonad (Maybe Lexeme)
popPending = do
    s <- Eff
  '[State ParseState, Error LexerError, StructuredDebug] ParseState
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
Eff es s
get
    case _pendingTokens s of
        (Lexeme
x : [Lexeme]
xs) -> ParseState -> LexMonad ()
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
s -> Eff es ()
put ParseState
s{_pendingTokens = xs} LexMonad () -> LexMonad (Maybe Lexeme) -> LexMonad (Maybe Lexeme)
forall a b.
Eff '[State ParseState, Error LexerError, StructuredDebug] a
-> Eff '[State ParseState, Error LexerError, StructuredDebug] b
-> Eff '[State ParseState, Error LexerError, StructuredDebug] b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Lexeme -> LexMonad (Maybe Lexeme)
forall a.
a -> Eff '[State ParseState, Error LexerError, StructuredDebug] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lexeme -> Maybe Lexeme
forall a. a -> Maybe a
Just Lexeme
x)
        [] -> Maybe Lexeme -> LexMonad (Maybe Lexeme)
forall a.
a -> Eff '[State ParseState, Error LexerError, StructuredDebug] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Lexeme
forall a. Maybe a
Nothing

{- | Emit DEDENTs for layout opened inside current delimiter depth, then the closer.
Return the first pending token (typically a DEDENT) so stream becomes "… <DEDENT> ) …"
-}
emitCloser :: Token -> SourceRegion -> LexMonad (Maybe Lexeme)
emitCloser :: Token -> SourceRegion -> LexMonad (Maybe Lexeme)
emitCloser Token
closerTok SourceRegion
closerReg = do
    LexMonad ()
flushLayoutBeforeCloser
    (ParseState -> ParseState) -> LexMonad ()
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
modify (Lens' ParseState Int
delimDepth Lens' ParseState Int -> (Int -> Int) -> ParseState -> ParseState
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (\Int
x -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)))
    let closerLex :: Lexeme
closerLex = SourceRegion -> Token -> Lexeme
forall a. SourceRegion -> a -> Located a
Located SourceRegion
closerReg Token
closerTok
    Lexeme -> LexMonad ()
pushBack Lexeme
closerLex
    m <- LexMonad (Maybe Lexeme)
popPending
    -- keep prevEndsExpr consistent
    case m of
        Just (Located SourceRegion
_ Token
tok) -> Bool -> LexMonad ()
setPrevEndsExpr (Token -> Bool
tokenEndsExpr Token
tok)
        Maybe Lexeme
Nothing -> Bool -> LexMonad ()
setPrevEndsExpr (Token -> Bool
tokenEndsExpr Token
closerTok)
    pure m

-- | Close only layout started at or inside current delimiter depth
flushLayoutBeforeCloser :: LexMonad ()
flushLayoutBeforeCloser :: LexMonad ()
flushLayoutBeforeCloser = do
    d <- Lens' ParseState Int
-> Eff '[State ParseState, Error LexerError, StructuredDebug] Int
forall k a (r :: [(* -> *) -> * -> *]) (is :: IxList) b.
(Is k A_Getter, State a :> r) =>
Optic' k is a b -> Eff r b
use' Lens' ParseState Int
delimDepth
    st <- get
    let stk = ParseState
st ParseState
-> Lens' ParseState (NonEmpty IndentInfo) -> NonEmpty IndentInfo
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' ParseState (NonEmpty IndentInfo)
indentStack
        (toClose, keep) = span (\IndentInfo
ii -> IndentInfo
ii IndentInfo -> Lens' IndentInfo Int -> Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' IndentInfo Int
openedAtDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
d) stk
    case keep of
        [] -> LexMonad ()
forall (f :: * -> *). Applicative f => f ()
pass -- base should remain
        (IndentInfo
b : [IndentInfo]
bs) -> do
            ParseState -> LexMonad ()
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
s -> Eff es ()
put (ParseState
st ParseState -> (ParseState -> ParseState) -> ParseState
forall a b. a -> (a -> b) -> b
& Lens' ParseState (NonEmpty IndentInfo)
indentStack Lens' ParseState (NonEmpty IndentInfo)
-> NonEmpty IndentInfo -> ParseState -> ParseState
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (IndentInfo
b IndentInfo -> [IndentInfo] -> NonEmpty IndentInfo
forall a. a -> [a] -> NonEmpty a
:| [IndentInfo]
bs))
            curPos <- Lens' ParseState RealPosition
-> Eff
     '[State ParseState, Error LexerError, StructuredDebug] RealPosition
forall k a (r :: [(* -> *) -> * -> *]) (is :: IxList) b.
(Is k A_Getter, State a :> r) =>
Optic' k is a b -> Eff r b
use' (Lens' ParseState AlexInput
input Lens' ParseState AlexInput
-> Lens' AlexInput RealPosition -> Lens' ParseState RealPosition
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' AlexInput RealPosition
position)
            ds <- catMaybes <$> mapM (\IndentInfo
lvl -> RealPosition -> RealPosition -> LexMonad (Maybe Lexeme)
emitDedentAt (IndentInfo
lvl IndentInfo -> Lens' IndentInfo RealPosition -> RealPosition
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' IndentInfo RealPosition
indentPos) RealPosition
curPos) toClose
            mapM_ pushFront (reverse ds)

emitLayoutAt :: Token -> RealSourceRegion -> LexMonad (Maybe Lexeme)
emitLayoutAt :: Token -> RealSourceRegion -> LexMonad (Maybe Lexeme)
emitLayoutAt Token
t RealSourceRegion
r = Maybe Lexeme -> LexMonad (Maybe Lexeme)
forall a.
a -> Eff '[State ParseState, Error LexerError, StructuredDebug] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lexeme -> Maybe Lexeme
forall a. a -> Maybe a
Just (SourceRegion -> Token -> Lexeme
forall a. SourceRegion -> a -> Located a
Located (RealSourceRegion -> SourceRegion
RealSourceRegion RealSourceRegion
r) Token
t))

emitIndentAt :: RealPosition -> LexMonad (Maybe Lexeme)
emitIndentAt :: RealPosition -> LexMonad (Maybe Lexeme)
emitIndentAt RealPosition
pos = do
    r <- RealPosition -> RealPosition -> LexMonad RealSourceRegion
createRegion RealPosition
pos RealPosition
pos
    emitLayoutAt TokenIndent r

emitDedentAt :: TokPosition -> TokPosition -> LexMonad (Maybe Lexeme)
emitDedentAt :: RealPosition -> RealPosition -> LexMonad (Maybe Lexeme)
emitDedentAt RealPosition
start RealPosition
end = do
    r <- RealPosition -> RealPosition -> LexMonad RealSourceRegion
createRegion RealPosition
start RealPosition
end
    emitLayoutAt TokenDedent r

emitLineSepAt :: RealPosition -> LexMonad (Maybe Lexeme)
emitLineSepAt :: RealPosition -> LexMonad (Maybe Lexeme)
emitLineSepAt RealPosition
pos = do
    r <- RealPosition -> RealPosition -> LexMonad RealSourceRegion
createRegion RealPosition
pos RealPosition
pos
    emitLayoutAt TokenLineSeparator r

startWhite :: Int -> Text -> LexMonad (Maybe Lexeme)
startWhite :: Int -> Text -> LexMonad (Maybe Lexeme)
startWhite Int
_ Text
str = do
    let indentation :: Int
indentation = Text -> Int
T.length (Text -> Int) -> Text -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') Text
str
    s <- Eff
  '[State ParseState, Error LexerError, StructuredDebug] ParseState
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
Eff es s
get
    let indents@(cur :| _) = s ^. indentStack

    curPos <- use' (input % position)
    let expectingLayout = Maybe LayoutExpectation -> Bool
forall a. Maybe a -> Bool
isJust (ParseState
s ParseState
-> Lens' ParseState (Maybe LayoutExpectation)
-> Maybe LayoutExpectation
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' ParseState (Maybe LayoutExpectation)
layoutExpected)
    layoutExpected .= Nothing

    case indentation `compare` (cur ^. indent) of
        Ordering
GT | Bool
expectingLayout -> do
            fakeLb <- RealPosition -> LexMonad (Maybe Lexeme)
emitIndentAt RealPosition
curPos
            indentInfo <- mkIndentInfo indentation
            let push = ([Lexeme] -> [Lexeme])
-> (Lexeme -> [Lexeme] -> [Lexeme])
-> Maybe Lexeme
-> [Lexeme]
-> [Lexeme]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Lexeme] -> [Lexeme]
forall a. a -> a
identity (:) Maybe Lexeme
fakeLb
            -- Indent starts a block, usually shouldn't immediately end expr
            setPrevEndsExpr False
            put s{_indentStack = indentInfo <| indents, _pendingTokens = push (_pendingTokens s)}
            pure Nothing
        Ordering
GT -> Maybe Lexeme -> LexMonad (Maybe Lexeme)
forall a.
a -> Eff '[State ParseState, Error LexerError, StructuredDebug] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Lexeme
forall a. Maybe a
Nothing -- ignore indentation increases that don't follow layout triggers
        Ordering
LT -> do
            -- Pop all levels strictly greater than current indentation
            let ([IndentInfo]
closingLevels, [IndentInfo]
topAndRest) = (IndentInfo -> Bool)
-> NonEmpty IndentInfo -> ([IndentInfo], [IndentInfo])
forall a. (a -> Bool) -> NonEmpty a -> ([a], [a])
span (Optic' A_Getter NoIx IndentInfo Bool -> IndentInfo -> Bool
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' IndentInfo Int
indent Lens' IndentInfo Int
-> Optic A_Getter NoIx Int Int Bool Bool
-> Optic' A_Getter NoIx IndentInfo Bool
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (Int -> Bool) -> Optic A_Getter NoIx Int Int Bool Bool
forall s a. (s -> a) -> Getter s a
to (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
indentation))) NonEmpty IndentInfo
indents

            case [IndentInfo]
topAndRest of
                (IndentInfo
top : [IndentInfo]
xs) -> do
                    eofPos <- Lens' ParseState RealPosition
-> Eff
     '[State ParseState, Error LexerError, StructuredDebug] RealPosition
forall k a (r :: [(* -> *) -> * -> *]) (is :: IxList) b.
(Is k A_Getter, State a :> r) =>
Optic' k is a b -> Eff r b
use' (Lens' ParseState AlexInput
input Lens' ParseState AlexInput
-> Lens' AlexInput RealPosition -> Lens' ParseState RealPosition
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' AlexInput RealPosition
position)

                    -- emit DEDENTs for everything we popped
                    dedents <- catMaybes <$> mapM (\IndentInfo
lvl -> RealPosition -> RealPosition -> LexMonad (Maybe Lexeme)
emitDedentAt (IndentInfo
lvl IndentInfo -> Lens' IndentInfo RealPosition -> RealPosition
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' IndentInfo RealPosition
indentPos) RealPosition
eofPos) closingLevels

                    -- check validity against the new top of stack
                    -- a valid continuation is one that is >= top indent
                    let validContinuation = Int
indentation Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= IndentInfo
top IndentInfo -> Lens' IndentInfo Int -> Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' IndentInfo Int
indent

                    if validContinuation
                        then do
                            -- emit separator _only_ if we match exactly, i.e. it's a new statement
                            -- if indentation > top, it's a continuation, so no separator
                            let isNewStmt = Int
indentation Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== IndentInfo
top IndentInfo -> Lens' IndentInfo Int -> Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' IndentInfo Int
indent

                            sep <-
                                if isNewStmt
                                    then emitLineSepAt eofPos
                                    else pure Nothing -- no separator for continuations
                            setPrevEndsExpr False

                            let closings = [Lexeme]
dedents [Lexeme] -> [Lexeme] -> [Lexeme]
forall a. Semigroup a => a -> a -> a
<> Maybe Lexeme -> [Lexeme]
forall a. Maybe a -> [a]
maybeToList Maybe Lexeme
sep

                            indentStack .= (top :| xs)
                            pendingTokens %= (closings <>)

                            pure Nothing
                        else
                            throwError (TooMuchIndentation top (viaNonEmpty last $ init indents) indentation s)
                [] -> Text
-> Eff
     '[State ParseState, Error LexerError, StructuredDebug]
     (Maybe (ZonkAny 0))
forall a t. (HasCallStack, IsText t) => t -> a
error (Text
" Indent stack contains nothing greater than " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
indentation)
            Maybe Lexeme -> LexMonad (Maybe Lexeme)
forall a.
a -> Eff '[State ParseState, Error LexerError, StructuredDebug] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Lexeme
forall a. Maybe a
Nothing
        Ordering
EQ -> do
            ends <- LexMonad Bool
getPrevEndsExpr
            pos <- use' (input % position)
            if ends
                then do
                    setPrevEndsExpr False
                    emitLineSepAt pos
                else pure Nothing

-- Insert dedent for any leftover unclosed indents
cleanIndentation :: LexMonad [Lexeme]
cleanIndentation :: Eff '[State ParseState, Error LexerError, StructuredDebug] [Lexeme]
cleanIndentation = do
    indentStack' <- Lens' ParseState (NonEmpty IndentInfo)
-> Eff
     '[State ParseState, Error LexerError, StructuredDebug]
     (NonEmpty IndentInfo)
forall k a (r :: [(* -> *) -> * -> *]) (is :: IxList) b.
(Is k A_Getter, State a :> r) =>
Optic' k is a b -> Eff r b
use' Lens' ParseState (NonEmpty IndentInfo)
indentStack
    case indentStack' of
        IndentInfo
_base :| [] -> [Lexeme]
-> Eff
     '[State ParseState, Error LexerError, StructuredDebug] [Lexeme]
forall a.
a -> Eff '[State ParseState, Error LexerError, StructuredDebug] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        NonEmpty IndentInfo
_ -> do
            let toClose :: [IndentInfo]
toClose = NonEmpty IndentInfo -> [IndentInfo]
forall (f :: * -> *) a. IsNonEmpty f a [a] "init" => f a -> [a]
init NonEmpty IndentInfo
indentStack'
                base :: IndentInfo
base = NonEmpty IndentInfo -> IndentInfo
forall (f :: * -> *) a. IsNonEmpty f a a "last" => f a -> a
last NonEmpty IndentInfo
indentStack'
            eofPos <- Lens' ParseState RealPosition
-> Eff
     '[State ParseState, Error LexerError, StructuredDebug] RealPosition
forall k a (r :: [(* -> *) -> * -> *]) (is :: IxList) b.
(Is k A_Getter, State a :> r) =>
Optic' k is a b -> Eff r b
use' (Lens' ParseState AlexInput
input Lens' ParseState AlexInput
-> Lens' AlexInput RealPosition -> Lens' ParseState RealPosition
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' AlexInput RealPosition
position)
            dedents <- catMaybes <$> mapM (\IndentInfo
lvl -> RealPosition -> RealPosition -> LexMonad (Maybe Lexeme)
emitDedentAt (IndentInfo
lvl IndentInfo -> Lens' IndentInfo RealPosition -> RealPosition
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' IndentInfo RealPosition
indentPos) RealPosition
eofPos) toClose
            indentStack .= (base :| [])
            pure dedents

-- The functions that must be provided to Alex's basic interface

-- | Read a byte from the input
alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
alexGetByte ai :: AlexInput
ai@AlexInput{Char
FilePath
[Word8]
Text
RealPosition
_filePath :: AlexInput -> FilePath
_prev :: AlexInput -> Char
_bytes :: AlexInput -> [Word8]
_rest :: AlexInput -> Text
_position :: AlexInput -> RealPosition
_filePath :: FilePath
_prev :: Char
_bytes :: [Word8]
_rest :: Text
_position :: RealPosition
..} =
    case [Word8]
_bytes of
        (Word8
b : [Word8]
bs) ->
            (Word8, AlexInput) -> Maybe (Word8, AlexInput)
forall a. a -> Maybe a
Just (Word8
b, AlexInput
ai{_bytes = bs})
        [] ->
            case Text -> Maybe (Char, Text)
T.uncons Text
_rest of
                Maybe (Char, Text)
Nothing -> Maybe (Word8, AlexInput)
forall a. Maybe a
Nothing
                Just (Char
char, Text
chars) ->
                    let (Position Int
n Int
c) = RealPosition
_position
                        n' :: Int
n' = if Char
char Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' then Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
n
                        c' :: Int
c' = if Char
char Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' then Int
1 else Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                        (Word8
b :| [Word8]
bs) = [Item (NonEmpty Word8)] -> NonEmpty Word8
forall l. IsList l => [Item l] -> l
fromList ([Item (NonEmpty Word8)] -> NonEmpty Word8)
-> [Item (NonEmpty Word8)] -> NonEmpty Word8
forall a b. (a -> b) -> a -> b
$ Char -> [Word8]
encodeChar Char
char
                     in (Word8, AlexInput) -> Maybe (Word8, AlexInput)
forall a. a -> Maybe a
Just
                            ( Word8
b
                            , AlexInput
ai
                                { _prev = char
                                , _bytes = bs
                                , _rest = chars
                                , _position = Position n' c'
                                }
                            )

getPosition :: Int -> LexMonad TokPosition
getPosition :: Int
-> Eff
     '[State ParseState, Error LexerError, StructuredDebug] RealPosition
getPosition Int
tokenLength = do
    ParseState{_input = AlexInput{_position = (Position ln cn)}} <- Eff
  '[State ParseState, Error LexerError, StructuredDebug] ParseState
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
Eff es s
get
    pure $ Position ln (cn - tokenLength)

createRegion :: TokPosition -> TokPosition -> LexMonad RealSourceRegion
createRegion :: RealPosition -> RealPosition -> LexMonad RealSourceRegion
createRegion RealPosition
start RealPosition
end = do
    fp <- Optic' A_Lens NoIx ParseState FilePath
-> Eff
     '[State ParseState, Error LexerError, StructuredDebug] FilePath
forall k a (r :: [(* -> *) -> * -> *]) (is :: IxList) b.
(Is k A_Getter, State a :> r) =>
Optic' k is a b -> Eff r b
use' (Lens' ParseState AlexInput
input Lens' ParseState AlexInput
-> Lens' AlexInput FilePath
-> Optic' A_Lens NoIx ParseState FilePath
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' AlexInput FilePath
filePath)
    pure $ mkSourceRegionIn (Just fp) start end

createRegionStartingAt :: TokPosition -> LexMonad RealSourceRegion
createRegionStartingAt :: RealPosition -> LexMonad RealSourceRegion
createRegionStartingAt RealPosition
start = do
    end <- Int
-> Eff
     '[State ParseState, Error LexerError, StructuredDebug] RealPosition
getPosition Int
0
    createRegion start end

{- | Splits a qualified name into the qualifier and the name.
Throws an error if the name is not qualified.

Examples:

>>> splitQualName "Hello.world"
(ModuleName ("Hello" :| []),"world")

>>> splitQualName "A.B.C"
(ModuleName ("A" :| ["B"]),"C")

>>> splitQualName "Prelude..+"
(ModuleName ("Prelude" :| []),".+")

>>> splitQualName "A.!."
(ModuleName ("A" :| []),"!.")
-}
splitQualName :: Text -> (ModuleName, Text)
splitQualName :: Text -> (ModuleName, Text)
splitQualName Text
t = do
    let parts :: [Text]
parts = HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
t
    case [Text]
parts of
        [] -> Text -> (ModuleName, Text)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Empty string"
        [Text
""] -> Text -> (ModuleName, Text)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Empty string"
        [Text
_] -> Text -> (ModuleName, Text)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"No module name"
        [Text]
xs ->
            -- we have to be careful here, we can't just take the 'init' because that will break operators that start with .
            -- >>> ["Prelude", "", "+"] = ("Prelude", ".+")
            -- >>> ["Prelude", "T"] = ("Prelude", "T")
            -- >>> ["Prelude", "T", ""] = ("Prelude.T", ".")
            -- >>> ["A", "!", ""] = ("A", "!.")
            let isAlphaNumeric :: Text -> Bool
isAlphaNumeric = (Char -> Bool) -> Text -> Bool
T.all (\Char
c -> Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c)
                ([Text]
modPart, [Text]
namePart) = (Text -> Bool) -> NonEmpty Text -> ([Text], [Text])
forall a. (a -> Bool) -> NonEmpty a -> ([a], [a])
span ((Bool -> Bool -> Bool)
-> (Text -> Bool) -> (Text -> Bool) -> Text -> Bool
forall a b c.
(a -> b -> c) -> (Text -> a) -> (Text -> b) -> Text -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) Text -> Bool
isAlphaNumeric (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null)) ([Item (NonEmpty Text)] -> NonEmpty Text
forall l. IsList l => [Item l] -> l
fromList [Text]
[Item (NonEmpty Text)]
xs)
             in if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
namePart
                    then -- TODO: this isn't very efficient
                        (NonEmpty Text -> ModuleName
ModuleName (NonEmpty Text -> ModuleName) -> NonEmpty Text -> ModuleName
forall a b. (a -> b) -> a -> b
$ [Item (NonEmpty Text)] -> NonEmpty Text
forall l. IsList l => [Item l] -> l
fromList (NonEmpty (Item (NonEmpty Text)) -> [Item (NonEmpty Text)]
forall (f :: * -> *) a. IsNonEmpty f a [a] "init" => f a -> [a]
init ([Item (NonEmpty (Item (NonEmpty Text)))]
-> NonEmpty (Item (NonEmpty Text))
forall l. IsList l => [Item l] -> l
fromList [Text]
[Item (NonEmpty (Item (NonEmpty Text)))]
modPart)), NonEmpty Text -> Text
forall (f :: * -> *) a. IsNonEmpty f a a "last" => f a -> a
last ([Item (NonEmpty Text)] -> NonEmpty Text
forall l. IsList l => [Item l] -> l
fromList [Text]
[Item (NonEmpty Text)]
modPart))
                    else (NonEmpty Text -> ModuleName
ModuleName (NonEmpty Text -> ModuleName) -> NonEmpty Text -> ModuleName
forall a b. (a -> b) -> a -> b
$ [Item (NonEmpty Text)] -> NonEmpty Text
forall l. IsList l => [Item l] -> l
fromList [Text]
[Item (NonEmpty Text)]
modPart, Text -> [Text] -> Text
T.intercalate Text
"." [Text]
namePart)