{-# LANGUAGE RankNTypes, TypeFamilies #-}

module ExprLexer (ExprToken(..), isSpace, isNum, CharParserA, pTokens) where

import Generics.Annotations.Satisfy
import Generics.Annotations.Token

import Control.Applicative
import Data.Maybe (fromJust)

-- | The type of expression tokens.
data ExprToken
  = Num Int
  | Plus
  | Minus
  | Star
  | Slash
  | POpen
  | PClose
  | Space String
  deriving (Eq, Show)

instance Symbol ExprToken where
  symbolSize = length . unparse . return
  spaceBeforeSize _ = 0
  spaceAfterSize _ = 0
  unparseS = foldr (.) id . map unparseExprTokenS

unparseExprTokenS :: ExprToken -> ShowS
unparseExprTokenS tok = case tok of
  Num n -> shows n
  Space s -> showString s
  _ -> showString (fromJust (lookup tok statics))

statics :: [(ExprToken, String)]
statics =
  [ (Plus, "+")
  , (Minus, "-")
  , (Star, "*")
  , (Slash, "/")
  , (POpen, "(")
  , (PClose, ")")
  ]

-- | Applicative parsers that consume characters.
type CharParserA a = SatisfyA Char a

-- pStaticToken :: TreeParser v Char ExprToken
pStaticToken :: CharParserA ExprToken
pStaticToken = choice $ map (\(tok, syn) -> tok <$ token syn) statics

-- pSpace :: TreeParser v Char ExprToken
pSpace :: CharParserA ExprToken
pSpace = Space <$> some (oneOf " \n\r\t\f")

-- | Whether the token is the Space constructor.
isSpace :: ExprToken -> Bool
isSpace (Space _) = True
isSpace _ = False

-- | Whether the token is the Num constructor.
isNum :: ExprToken -> Bool
isNum (Num _) = True
isNum _ = False

-- pToken :: TreeParser v Char ExprToken
pToken :: CharParserA ExprToken
pToken = choice [pStaticToken, pInt, pSpace]

-- pInt :: TreeParser v Char Int
pInt :: CharParserA ExprToken
pInt = (\d ds -> Num (read (d:ds))) <$> oneOf ['1'..'9'] <*> many (oneOf ['0'..'9'])

-- | The lexer that when run converts a stream of characters to a stream of tokens.
pTokens :: CharParserA [Token ExprToken]
pTokens = collapse isSpace <$> many pToken