TokenTypes.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Contains class instances and functions related to tokens
module GLua.TokenTypes where

import Data.Aeson (FromJSON, ToJSON)
import Data.List (foldl', partition)
import GHC.Generics (Generic)
import GLua.AG.Token (MToken (..), Token (..))
import GLua.Position (LineColPos (..), Region (..))

instance Show MToken where
  show (MToken _ tok) = show tok

-- | Simple EQ instance. TODO: check for position equality
instance Eq MToken where
  (MToken _ t1) == (MToken _ t2) = t1 == t2

-- | Simple Ord instance. TODO: check for position Ord
instance Ord MToken where
  compare (MToken _ t1) (MToken _ t2) = compare t1 t2

deriving instance Generic MToken

instance ToJSON MToken
instance FromJSON MToken

instance ToJSON Token
instance FromJSON Token

mpos :: MToken -> Region
mpos (MToken p _) = p

mtok :: MToken -> Token
mtok (MToken _ t) = t

-- | Map function for an MToken
mapMtok :: (Token -> a) -> MToken -> a
mapMtok f (MToken _ t) = f t

----------------------------------------
--  Correcting token positions
----------------------------------------
customAdvanceChr :: LineColPos -> Char -> LineColPos
customAdvanceChr (LineColPos line _ abs') '\n' = LineColPos (line + 1) 0 (abs' + 1)
customAdvanceChr (LineColPos line pos' abs') _ = LineColPos line (pos' + 1) (abs' + 1)

customAdvanceStr :: LineColPos -> String -> LineColPos
customAdvanceStr = foldl' customAdvanceChr

customAdvanceToken :: LineColPos -> Token -> LineColPos
customAdvanceToken (LineColPos line pos' abs') t = let len = tokenSize t in LineColPos line (pos' + len) (abs' + len)

-- | Simple show instance
instance Show Token where
  show token = case token of
    Whitespace s -> s
    DashComment c -> "--" ++ c
    DashBlockComment d s -> let n = replicate d '=' in "--[" ++ n ++ '[' : s ++ ']' : n ++ "]"
    SlashComment c -> "//" ++ c
    SlashBlockComment s -> "/*" ++ s ++ "*/"
    Semicolon -> ";"
    TNumber n -> n
    DQString s -> "\"" ++ s ++ "\""
    SQString s -> "'" ++ s ++ "'"
    MLString s -> s
    TTrue -> "true"
    TFalse -> "false"
    Nil -> "nil"
    VarArg -> "..."
    Plus -> "+"
    Minus -> "-"
    Multiply -> "*"
    Divide -> "/"
    Modulus -> "%"
    Power -> "^"
    TEq -> "=="
    TNEq -> "~="
    TCNEq -> "!="
    TLEQ -> "<="
    TGEQ -> ">="
    TLT -> "<"
    TGT -> ">"
    Equals -> "="
    Concatenate -> ".."
    Colon -> ":"
    Dot -> "."
    Comma -> ","
    Hash -> "#"
    Not -> "not"
    CNot -> "!"
    And -> "and"
    CAnd -> "&&"
    Or -> "or"
    COr -> "||"
    Function -> "function"
    Local -> "local"
    If -> "if"
    Then -> "then"
    Elseif -> "elseif"
    Else -> "else"
    For -> "for"
    In -> "in"
    Do -> "do"
    While -> "while"
    Until -> "until"
    Repeat -> "repeat"
    Continue -> "continue"
    Break -> "break"
    Return -> "return"
    End -> "end"
    LRound -> "("
    RRound -> ")"
    LCurly -> "{"
    RCurly -> "}"
    LSquare -> "["
    RSquare -> "]"
    Label spaceBefore ident spaceAfter -> spaceBefore ++ ident ++ spaceAfter
    Identifier i -> i

-- | Whether an mtoken is a comment
isWhitespace :: MToken -> Bool
isWhitespace = mapMtok $ \case
  Whitespace{} -> True
  _ -> False

-- | Whether an mtoken is a comment
isComment :: MToken -> Bool
isComment = mapMtok $ \case
  DashComment{} -> True
  DashBlockComment{} -> True
  SlashComment{} -> True
  SlashBlockComment{} -> True
  _ -> False

-- | Split the tokens by comments and other tokens
splitComments :: [MToken] -> ([MToken], [MToken])
splitComments = partition isComment

-- | Extracts the label name out of the token, returns empty string when the token is not a label or
-- identifier.
tokenLabel :: MToken -> String
tokenLabel = mapMtok $ \case
  Label _ ident _ -> ident
  Identifier ident -> ident
  _ -> ""

-- | The size of a token in characters
tokenSize :: Token -> Int
tokenSize = \case
  Whitespace s -> length s
  DashComment c -> 2 + length c
  DashBlockComment d s -> 6 + length s + 2 * d
  SlashComment c -> length c + 2
  SlashBlockComment s -> length s + 2
  Semicolon -> 1
  TNumber n -> length n
  DQString s -> length s + 2
  SQString s -> length s + 2
  MLString s -> length s
  TTrue -> 4
  TFalse -> 5
  Nil -> 3
  VarArg -> 3
  Plus -> 1
  Minus -> 1
  Multiply -> 1
  Divide -> 1
  Modulus -> 1
  Power -> 1
  TEq -> 2
  TNEq -> 2
  TCNEq -> 2
  TLEQ -> 2
  TGEQ -> 2
  TLT -> 1
  TGT -> 1
  Equals -> 1
  Concatenate -> 2
  Colon -> 1
  Dot -> 1
  Comma -> 1
  Hash -> 1
  Not -> 3
  CNot -> 1
  And -> 3
  CAnd -> 2
  Or -> 2
  COr -> 2
  Function -> 8
  Local -> 5
  If -> 2
  Then -> 4
  Elseif -> 6
  Else -> 4
  For -> 3
  In -> 2
  Do -> 2
  While -> 5
  Until -> 5
  Repeat -> 6
  Continue -> 8
  Break -> 5
  Return -> 6
  End -> 3
  LRound -> 1
  RRound -> 1
  LCurly -> 1
  RCurly -> 1
  LSquare -> 1
  RSquare -> 1
  Label spaceBefore ident spaceAfter -> 2 + length spaceBefore + length ident + length spaceAfter + 2
  Identifier i -> length i