{-# 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 Effectful (Eff)
import Effectful.Error.Static
import Effectful.State.Static.Local
import Error.Diagnose (Marker (..), Note (..), Report (Err))

import Data.Text qualified as T

import Effectful.State.Extra (use', (%=), (.=))
import Elara.AST.Name (ModuleName (..))
import Elara.AST.Region (Located (Located), RealPosition (..), RealSourceRegion (..), SourceRegion (..), mkSourceRegionIn, positionToDiagnosePosition)
import Elara.Data.Pretty hiding (indent)
import Elara.Error
import Elara.Error.Diagnose (toDiagnoseReports)
import Elara.Lexer.Token (Lexeme, TokPosition, Token (..), tokenEndsExpr)
import Elara.Logging (StructuredDebug)
import Prelude hiding (span)

import Elara.Error.Codes qualified as Codes

data AlexInput = AlexInput
    { AlexInput -> FilePath
_filePath :: FilePath
    , AlexInput -> Char
_prev :: Char
    , AlexInput -> [Word8]
_bytes :: [Word8]
    , AlexInput -> Text
_rest :: Text
    , AlexInput -> RealPosition
_position :: RealPosition
    }
    deriving ((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, 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)
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 ((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, 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)

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 ((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, 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)

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, (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, 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)
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 ((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, 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)

instance Pretty LexerError

instance Exception LexerError

instance ElaraDiagnostic LexerError where
    diagnosticMessage :: LexerError -> Doc AnsiStyle
diagnosticMessage (TooMuchIndentation{}) = Doc AnsiStyle
"Unexpected change in indentation"
    diagnosticMessage (GenericAlexError AlexInput
_) = Doc AnsiStyle
"Lexical error"
    diagnosticMessage (UnterminatedStringLiteral ParseState
_) = Doc AnsiStyle
"Unterminated string literal"

    diagnosticCode :: LexerError -> Maybe ErrorCode
diagnosticCode (TooMuchIndentation{}) = ErrorCode -> Maybe ErrorCode
forall a. a -> Maybe a
Just ErrorCode
Codes.tooMuchIndentation
    diagnosticCode (GenericAlexError AlexInput
_) = ErrorCode -> Maybe ErrorCode
forall a. a -> Maybe a
Just ErrorCode
Codes.genericLexicalError
    diagnosticCode (UnterminatedStringLiteral ParseState
_) = ErrorCode -> Maybe ErrorCode
forall a. a -> Maybe a
Just ErrorCode
Codes.unterminatedStringLiteral

    diagnosticMarkers :: LexerError -> [ElaraMarker]
diagnosticMarkers (TooMuchIndentation IndentInfo
_ Maybe IndentInfo
_ Int
_ ParseState
s) = [SourceRegion -> ElaraMarkerType -> Doc AnsiStyle -> ElaraMarker
ElaraMarker (RealSourceRegion -> SourceRegion
RealSourceRegion (RealSourceRegion -> SourceRegion)
-> RealSourceRegion -> SourceRegion
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
Maybe FilePath -> RealPosition -> RealPosition -> RealSourceRegion
Maybe FilePath -> RealPosition -> RealPosition -> RealSourceRegion
mkSourceRegionIn (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ 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) (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) (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)) ElaraMarkerType
PrimaryMarker Doc AnsiStyle
"this line is indented incorrectly"]
    diagnosticMarkers (GenericAlexError AlexInput
ai) = [SourceRegion -> ElaraMarkerType -> Doc AnsiStyle -> ElaraMarker
ElaraMarker (RealSourceRegion -> SourceRegion
RealSourceRegion (RealSourceRegion -> SourceRegion)
-> RealSourceRegion -> SourceRegion
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
Maybe FilePath -> RealPosition -> RealPosition -> RealSourceRegion
Maybe FilePath -> RealPosition -> RealPosition -> RealSourceRegion
mkSourceRegionIn (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ 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) (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) (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)) ElaraMarkerType
PrimaryMarker Doc AnsiStyle
"lexical error occurred here"]
    diagnosticMarkers (UnterminatedStringLiteral ParseState
s) = [SourceRegion -> ElaraMarkerType -> Doc AnsiStyle -> ElaraMarker
ElaraMarker (RealSourceRegion -> SourceRegion
RealSourceRegion (RealSourceRegion -> SourceRegion)
-> RealSourceRegion -> SourceRegion
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
Maybe FilePath -> RealPosition -> RealPosition -> RealSourceRegion
Maybe FilePath -> RealPosition -> RealPosition -> RealSourceRegion
mkSourceRegionIn (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ 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) (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) (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)) ElaraMarkerType
PrimaryMarker Doc AnsiStyle
"this string literal is unterminated"]

    diagnosticNotes :: LexerError -> [ElaraNote]
diagnosticNotes (TooMuchIndentation IndentInfo
_ Maybe IndentInfo
further Int
actual ParseState
_) =
        let hint :: FilePath
hint = case Maybe IndentInfo
further of
                Maybe IndentInfo
Nothing -> FilePath
"Try removing the extra indentation."
                Just IndentInfo
f -> FilePath
"Try removing the extra indentation or indenting the line by " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
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) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" space(s)."
         in [ Doc AnsiStyle -> ElaraNote
Elara.Error.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 -> ElaraNote
Elara.Error.Hint (FilePath -> Doc AnsiStyle
forall a. Pretty a => a -> Doc AnsiStyle
pretty FilePath
hint)
            ]
    diagnosticNotes (GenericAlexError AlexInput
_) =
        [ Doc AnsiStyle -> ElaraNote
Elara.Error.Note Doc AnsiStyle
"The lexer encountered an invalid character or sequence of characters that it could not process."
        ]
    diagnosticNotes (UnterminatedStringLiteral ParseState
_) =
        [ Doc AnsiStyle -> ElaraNote
Elara.Error.Note Doc AnsiStyle
"String literals are delimited by double quotes (\")."
        , Doc AnsiStyle -> ElaraNote
Elara.Error.Hint Doc AnsiStyle
"Make sure that the string literal is terminated with a double quote (\")."
        ]

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)