{-# LANGUAGE TypeFamilies #-}

module Token (
    Token, tSpaceBefore, tImage, tSpaceAfter,
    collapse, lift, (>&)
  ) where

import TreeParser
import ParseTree
import SucParser
import qualified Control.Monad.State as S
import ParserClass

-- | A token is a symbol in an input stream accompanied by whitespace on both sides.
data Token s
  = Token
    { tSpaceBefore  :: [s]  -- ^ Yields the whitespace preceding this token.
    , tImage        :: s    -- ^ Yields the meaningful symbol of this token.
    , tSpaceAfter   :: [s]  -- ^ Yields the whitespace succeeding this token.
    }
  deriving Eq

instance (Symbol s) => Symbol (Token s) where
  symbolSize (Token _ im _)       = symbolSize im
  spaceBeforeSize (Token sb _ _)  = sum (map symbolSize sb)
  spaceAfterSize (Token _ _ sa)   = sum (map symbolSize sa)

instance Show s => Show (Token s) where
  showsPrec _ (Token _ im _) = (show im ++)
  showList [] = id
  showList [Token sb im sa] = (concatMap show sb ++) . (show im ++) . (concatMap show sa ++)
  showList ((Token sb im _):ts) = (concatMap show sb ++) . (show im ++) . showList ts

-- | Given a predicate that tells when a symbol is whitespace, converts a list of symbols to a list of tokens.
collapse :: (s -> Bool) -> [s] -> [Token s]
collapse space input = collapse' space xs yzs
  where
    (xs, yzs) = span space input

collapse' :: (s -> Bool) -> [s] -> [s] -> [Token s]
collapse' space spaceBefore input = output where
  output = if null input then [] else token : rest
  token = Token
    { tImage = head input
    , tSpaceBefore = spaceBefore
    , tSpaceAfter = spaceAfter
    }
  (spaceAfter, toProcess) = span space (tail input)
  rest = collapse' space spaceAfter toProcess

-- | Converts a parser of @s@'s to a parser of 'Token' @s@'s.
lift :: TreeParser (SucParser s) v a -> TreeParser (SucParser (Token s)) v a
lift = mapInput tImage

-- | Concatenates a lexer and a parser, producing a direct parse function.
(>&) :: (Maybe ~ ParseResult p, Parser p) => p [Token s] -> TreeParser (SucParser s) v a
          -> [Input p] -> Maybe (ParseTree (Token s) v)
(p >& q) input = do  -- Maybe monad
  toks <- runParser p input
  tree <- runParser (getTree $ lift q) toks
  return tree