Lexer.x

{
{-# OPTIONS_GHC -Wno-name-shadowing #-}
module Zwirn.Language.Lexer
  ( -- * Invoking Alex
    Alex
  , AlexPosn (..)
  , alexGetInput
  , alexError
  , runAlex
  , alexMonadScan

  , Lexeme
  , Token (..)
  , scanMany
  , increaseChoice
  , setSrcPath
  , getSrcPath
  , setInitialLineNum
  , lineLexer
  , typeLexer
  ) where

{-
    Lexer.hs - lexer for zwirn, code adapted from
    https://serokell.io/blog/lexing-with-alex
    Copyright (C) 2025, Martin Gius

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  IfTok not, see <http://www.gnu.org/licenses/>.
-}

import           Data.Text (Text)
import qualified Data.Text as Text
import Control.Monad (when)
import Zwirn.Language.Location

}

%wrapper "monadUserState-strict-text"

$digit = [0-9]
$alphasmall = [a-z]
$alphabig = [A-Z]
$alpha = [a-zA-Z]

@id = ($alphasmall) ($alpha | $digit | \_ )*
@single = ("&" | "$" | "?" | "#" | "." | "^" | ":")
@reserved = ("|" | "=" | "~" | "%" | "!")
@special = ("*" | "/" | "'" | "+" | "-")
@op = ((@single (@single | @reserved | @special)*)
      |((@reserved | "<" | @special) (@single | @reserved | @special)+)
      |((@reserved | ">" | @special) (@single | @reserved | ">")  (@single | @reserved | ">" | @special)+)
      )
@num = ("-")? ($digit)+ ("." ($digit)+)?
@path = $white ($alpha | "/" | ".")+
@flag = $alphabig $alpha*

tokens :-

<0> $white+ ;


-- Single Line Comments
<line> "--" .* (\n?) ;

<line> (.+ (\n?) | \n)             { mkLine }


<ty> $white+ ;
<ty> $alpha+ "." ;
<ty> "=>"                          { tok TypeContextTok }
<ty> "->"                          { tok ArrowTok }
<ty> "("                           { tok LParTok }
<ty> ")"                           { tok RParTok }
<ty> ","                           { tok CommaTok }
<ty> "Text"                        { tok TextTypeTok }
<ty> "Number"                      { tok NumberTypeTok }
<ty> "Map"                         { tok MapTypeTok }
<ty> "Action"                      { tok ActionTypeTok }
<ty> @id                           { tokText VarTypeTok }
<ty> [A-Z] $alphasmall+            { tokText TypeClassTok }
<ty> @id                           { tokText IdentifierTok }
<ty> @op                           { tokText OperatorTok }
<ty> @special                      { tokText SpecialOperatorTok }

-- Single Line Comments
<0>  "--" .* (\n?) ;

-- Macro

<0> "!"($alphasmall)+ { tokText (\t -> MacroTok $ Text.drop 1 t)}

-- Repeat
<0> "!"               { tok RepeatTok }
<0> "!"($digit+)      { tokText (\t -> RepeatNumberTok $ Text.drop 1 t) }

-- Parenthesis
<0> "("     { tok LParTok }
<0> ")"     { tok RParTok }

-- Sequences
<0> "["     { tok LBrackTok }
<0> "]"     { tok RBrackTok }

-- Stacks
<0> ","     { tok CommaTok }

-- Choice
<0> "|"     { tok ChoiceTok }

-- Enum
<0> ".."    { tok EnumTok }

-- Polyrhythm
<0> "%"     { tok PolyTok }

<0> "{"     { tok LBracesTok }
<0> "}"     { tok RBracesTok }

-- Lambda
<0> "\"     { tok LambdaTok }
<0> "->"    { tok ArrowTok }

-- Definitions
<0> "="                               { tok DefineTok }
<0> "<-"                              { tok DynamicDefineTok }

-- Commands
<0> ":t"                              { tok TypeCommandTok }
<0> ":show"                           { tok ShowCommandTok }
<0> ":config"                         { tok ShowConfigCommandTok }
<0> ":resetconfig"                    { tok ResetShowConfigCommandTok }
<0> ":info"                           { tok InfoCommandTok }
<0> ":reset"                          { tok ResetEnvCommandTok }
<0> ":set"                            { tok SetCommandTok }
<0> ":status"                         { tok StatusCommandTok }
<0> ":env"                            { tok EnvCommandTok }
<0> (":load") @path                   { tokText (\t -> LoadCommandTok $ Text.drop 6 t) }

-- Keywords
<0> if      { tok IfTok }
<0> then    { tok ThenTok }
<0> else    { tok ElseTok }

-- Identifiers
<0> @id             { tokText IdentifierTok }

-- Constants
<0> @num            { tokText NumberTok }
<0> \"[^\"]*\"      { tokText TextTok }
<0> "~"             { tok RestTok }
<0> "_"             { tok UnderscoreTok }

-- Compiler Flags

<0> @flag           { tokText CompilerFlagTok }

-- Operators
<0> @op             { tokText OperatorTok }
<0> @special        { tokText SpecialOperatorTok }

-- Alternations
<0> "<"     { tok LAngleTok }
<0> ">"     { tok RAngleTok }

{
data AlexUserState = AlexUserState
  { nestLevel :: Int
  , choiceNum :: Int
  , srcPath :: Text
  }

alexInitUserState :: AlexUserState
alexInitUserState = AlexUserState { nestLevel = 0, choiceNum = 0, srcPath = Text.empty}

get :: Alex AlexUserState
get = Alex $ \s -> Right (s, alex_ust s)

put :: AlexUserState -> Alex ()
put s' = Alex $ \s -> Right (s{alex_ust = s'}, ())

modify :: (AlexUserState -> AlexUserState) -> Alex ()
modify f = Alex $ \s -> Right (s{alex_ust = f (alex_ust s)}, ())

alexEOF :: Alex Lexeme
alexEOF = pure $ Located NoLoc EOF

type Lexeme = Located Token

data Token
  -- Identifiers
  = IdentifierTok Text
  -- Constants
  | TextTok Text
  | NumberTok Text
  | MacroTok Text
  | RestTok
  | UnderscoreTok
  -- Operators
  | OperatorTok Text
  | SpecialOperatorTok Text
  -- Repeat
  | RepeatTok
  | RepeatNumberTok Text
  -- Parenthesis
  | LParTok
  | RParTok
  -- Sequences
  | LBrackTok
  | RBrackTok
  -- Stacks
  | CommaTok
  -- Alternations
  | LAngleTok
  | RAngleTok
  -- Choice
  | ChoiceTok
  -- Polyrhythm
  | PolyTok
  | LBracesTok
  | RBracesTok
  -- LambdaTok
  | LambdaTok
  | ArrowTok
  -- If Then Else
  | IfTok
  | ThenTok
  | ElseTok
  -- Enum
  | EnumTok
  -- Definitions
  | DefineTok
  | DynamicDefineTok
  -- Commands
  | TypeCommandTok
  | ShowCommandTok
  | ShowConfigCommandTok
  | ResetShowConfigCommandTok
  | LoadCommandTok Text
  | InfoCommandTok
  | ResetEnvCommandTok
  | SetCommandTok
  | StatusCommandTok
  | EnvCommandTok
  | CompilerFlagTok Text
  -- Line & Block Tokens
  | LineTok Text
  | BlockSepTok
  -- Type Tokens
  | TypeContextTok
  | TextTypeTok
  | NumberTypeTok
  | MapTypeTok
  | ActionTypeTok
  | VarTypeTok Text
  | TypeClassTok Text
  -- EOF
  | EOF
  deriving (Eq)

instance Show Token where
 show (IdentifierTok s) = show s
 show (TextTok s) = show s
 show (NumberTok d) = show d
 show (MacroTok d) = show d
 show RestTok = quoted "~"
 show UnderscoreTok = quoted "_"
 show (OperatorTok o) = show o
 show (SpecialOperatorTok o) = show o
 show RepeatTok = quoted "!"
 show (RepeatNumberTok x) = quoted "!" ++ show x
 show LParTok = quoted "("
 show RParTok = quoted ")"
 show LBrackTok = quoted "["
 show RBrackTok = quoted "]"
 show CommaTok = quoted ","
 show LAngleTok = quoted "<"
 show RAngleTok = quoted ">"
 show ChoiceTok = quoted "|"
 show PolyTok = quoted "%"
 show LBracesTok = quoted "{"
 show RBracesTok = quoted "}"
 show LambdaTok = quoted "\\"
 show ArrowTok = quoted "->"
 show IfTok = quoted "if"
 show ThenTok = quoted "then"
 show ElseTok = quoted "else"
 show EnumTok = quoted ".."
 show DynamicDefineTok = quoted "<-"
 show TypeCommandTok = quoted ":t"
 show ShowCommandTok = quoted ":show"
 show ShowConfigCommandTok = quoted ":config"
 show ResetShowConfigCommandTok = quoted ":resetconfig"
 show DefineTok = quoted "="
 show (LoadCommandTok x) = ":load " <> show x
 show InfoCommandTok = quoted ":info"
 show ResetEnvCommandTok = quoted ":reset"
 show SetCommandTok = quoted ":set"
 show StatusCommandTok = quoted ":status"
 show EnvCommandTok = quoted ":env"
 show (CompilerFlagTok x) = show x
 show (LineTok t) = "line " <> show t
 show BlockSepTok = "block"
 show TypeContextTok = "=>"
 show TextTypeTok = "Text"
 show NumberTypeTok = "Number"
 show MapTypeTok = "Map"
 show ActionTypeTok = "Action"
 show (VarTypeTok t) = show t
 show (TypeClassTok c) = show c
 show EOF = "end of file"

quoted :: String -> String
quoted s = "'" ++ s ++ "'"

mkSrcLoc :: AlexAction SrcLoc
mkSrcLoc (st@(AlexPn _ lst cst), _, _, str) len = do
                       let (AlexPn _ lnen cen) = Text.foldl' alexMove st $ Text.take len str
                       p <- getSrcPath
                       return $ SrcLoc $ RealSrcLoc p lst cst lnen cen

mkLine :: AlexAction Lexeme
mkLine inp@(_, _, _, str) len = case Text.all (\c -> elem c ("\n\t " :: String)) (Text.take len str) of
                            True -> tok BlockSepTok inp len
                            False -> do
                                loc <- mkSrcLoc inp len
                                return $ Located loc (LineTok (Text.take len str))

tok :: Token -> AlexAction Lexeme
tok ctor inp len = do
            loc <- mkSrcLoc inp len
            return $ Located loc ctor


tokText :: (Text -> Token) -> AlexAction Lexeme
tokText f inp@(_, _, _, str) len = do
            loc <- mkSrcLoc inp len
            return $ Located loc (f $ Text.take len str)


increaseChoice :: Alex Int
increaseChoice = do
  (AlexUserState c x e) <- get
  put $ AlexUserState c (x+1) e
  return x

getSrcPath :: Alex Text
getSrcPath = do
  (AlexUserState _ _ p) <- get
  return p

setSrcPath :: Text -> Alex ()
setSrcPath i = do
  (AlexUserState c x _) <- get
  put $ AlexUserState c x i

setInitialLineNum :: Int -> Alex ()
setInitialLineNum i = Alex alex
                    where alex s = Right (s {alex_pos = AlexPn x i c }, ())
                                 where AlexPn x _ c = alex_pos s

lineLexer :: Alex ()
lineLexer = alexSetStartCode line

typeLexer :: Alex ()
typeLexer = alexSetStartCode ty

scanMany :: Text -> Either String [Lexeme]
scanMany input = runAlex input go
  where
    go = do
      output <- lineLexer >> alexMonadScan
      if lValue output == EOF
        then pure [output]
        else ((output) :) <$> go
}