Tokens.hs

module Compiler.Lexer.Tokens where

import Control.Applicative
import Data.List (intersperse)
import qualified Data.Text as T
import System.Console.ANSI (Color(..))

import Common
import Compiler.Lexer.Comments
import Compiler.Lexer.Delimeters
import Compiler.Lexer.Identifiers
import Compiler.Lexer.Keywords
import Compiler.Lexer.Literals
import Compiler.Lexer.Operators
import Compiler.Lexer.Whitespaces
import Parser
import Test.Common
import DiffRender.DiffRender
import Highlighter.Highlighter

data Token = Token
   { tkRaw       :: TokenRaw
   , tkLocation  :: Location
   , tkOffsetEnd :: Int
   } deriving (Show)

highlightTokens :: (StyledText, Maybe Token) -> StyledText
highlightTokens (src, Nothing) = src
highlightTokens (src, Just (tkRaw -> tk)) =
  case tk of
    TkKeyword _    -> StyledText (Fg Red) [src] --setSGRCode [SetColor Foreground Vivid Red]
    TkDelimeter _  -> StyledText (Fg Blue) [src] -- setSGRCode [SetColor Foreground Vivid Blue]
    TkLiteral _    -> StyledText (Fg Magenta) [src] -- setSGRCode [SetColor Foreground Vivid Magenta]
    TkOperator _   -> StyledText (Fg Cyan) [src] -- setSGRCode [SetColor Foreground Vivid Cyan]
    TkIdentifier _ -> StyledText (Fg Yellow) [src] --  setSGRCode [SetColor Foreground Vivid Yellow]
    TkComment _    -> StyledText (Fg Black) [src]
    TkWhitespace _ -> src

instance Highlightable Token where
  getTokenLoc = tkLocation
  highlight = highlightTokens
  pairWithTokens tokenStack startOffset source =
    genericPairWithTokens tkOffsetEnd tkLocation startOffset source tokenStack

instance Eq Token where
  (Token tr1 _ _ ) == (Token tr2 _ _) = tr1 == tr2

data TokenRaw
  = TkKeyword Keyword
  | TkDelimeter Delimeter
  | TkLiteral Literal
  | TkOperator Operator
  | TkWhitespace Whitespace
  | TkIdentifier Identifier
  | TkComment Comment
  deriving (Show, Eq)

instance HasParser TokenRaw where
  parser
    = (TkComment <$> parser)
    <|> (TkOperator <$> parser)
    <|> (TkKeyword <$> parser)
    <|> (TkDelimeter <$> parser)
    <|> (TkLiteral <$> parser)
    <|> (TkWhitespace <$> parser)
    <|> (TkIdentifier <$> parser)

-- This is expected to return the exact source
-- that was parsed into the token, and this property
-- is used in syntax-highlighting.
instance ToSource TokenRaw where
  toSource = \case
    TkKeyword kw   -> toSource kw
    TkDelimeter d  -> toSource d
    TkLiteral l    -> toSource l
    TkOperator o   -> toSource o
    TkWhitespace w -> toSource w
    TkComment w    -> toSource w
    TkIdentifier i -> toSource i

instance {-# OVERLAPPING #-} ToSource [TokenRaw] where
  toSource a = T.concat $ toSource <$> a

instance {-# OVERLAPPING #-} ToSource [Token] where
  toSource a = T.concat $ toSource <$> a

instance HasGen TokenRaw where
  getGen = choice
    [ (TkKeyword <$> getGen)
    , (TkDelimeter <$> getGen)
    , (TkLiteral <$> getGen)
    , (TkOperator <$> getGen)
    , (TkWhitespace <$> getGen)
    , (TkComment <$> getGen)
    ]

instance {-# OVERLAPS #-} HasGen [TokenRaw] where
  getGen =
    (normalizeWhiteSpace . intersperse (TkWhitespace $ Space 1)) <$> (list (linear 0 500) getGen)

normalizeWhiteSpace :: [TokenRaw] -> [TokenRaw]
normalizeWhiteSpace (TkWhitespace (Space w1) : TkWhitespace (Space w2) : rst) =
  normalizeWhiteSpace (TkWhitespace (Space (w1 + w2)) : rst)
normalizeWhiteSpace (TkWhitespace (NewLine w1) : TkWhitespace (NewLine w2) : rst) =
  normalizeWhiteSpace (TkWhitespace (NewLine (w1 + w2)) : rst)
normalizeWhiteSpace (h:rst) = h : normalizeWhiteSpace rst
normalizeWhiteSpace [] = []

instance HasInnerParseable Token where
  type InnerToken Token = TokenRaw
  assemble = Token

instance HasGen Token where
  getGen = Token <$> getGen <*> (pure emptyLocation) <*> (pure 0)

instance ToSource Token where
  toSource (Token tr _ _) = toSource tr

instance {-# OVERLAPS #-} HasGen [Token] where
  getGen = (fmap (\tr -> Token tr emptyLocation 0)) <$> getGen