{-# LANGUAGE BangPatterns #-}
  | Tokenizer for ACE . Tokens retain source locations ( line and column ) .

module ACE.Tokenizer where

import           ACE.Types.Tokens

import           Control.Applicative
import           Control.Arrow
import           Control.Monad
import           Data.Attoparsec.Text hiding (number)
import           Data.Char
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read as T

  | Tokenize some complete ACE text .
tokenize :: Text -> Either String [Token]
tokenize =
  parseOnly (fmap fst tokenizer <* endOfInput)

-- | The tokenizer.
tokenizer :: Parser ([Token],(Int,Int))
tokenizer =
  manyWithPos (spaces >=> token)
              genitive
              (1,0)

-- | Parse a token.
token :: (Int,Int) -> Parser (Token,(Int,Int))
token pos =
  number pos <|>
  quotedString pos <|>
  period pos <|>
  comma pos <|>
  questionMark pos <|>
  word pos

-- | Parse a number.
number :: (Int, Int) -> Parser (Token, (Int,Int))
number pos =
  fmap (\n -> (Number pos (either (const 0) fst (T.decimal n)),second (+ T.length n) pos))
       (takeWhile1 isDigit)

-- | Parse a quoted string, @\"foobar\"@.
quotedString :: (Int,Int) -> Parser (Token,(Int,Int))
quotedString pos =
  char '"' *> (cons <$> takeWhile1 (/='"')) <* char '"'
  where
    cons x =
      (QuotedString pos x
      ,second (+ (T.length x + 2)) pos)

-- | Parse a period \".\".
period :: (Int,Int) -> Parser (Token,(Int,Int))
period pos =
  char '.' *> pure (Period pos,second (+1) pos)

  | Parse a comma \",\ " .
comma :: (Int,Int) -> Parser (Token,(Int,Int))
comma pos =
  char ',' *> pure (Comma pos,second (+1) pos)

-- | Parse a question mark \"?\".
questionMark :: (Int,Int) -> Parser (Token,(Int,Int))
questionMark pos =
  char '?' *> pure (QuestionMark pos,second (+1) pos)

-- | Parse a word, which is any sequence of non-whitespace words
-- containing none of the other token characters.
word :: (Int,Int) -> Parser (Token,(Int,Int))
word pos =
  cons <$> takeWhile1 wordChar
  where
    cons w = (Word pos w,second (+ T.length w) pos)
    wordChar c =
      not (isSpace c) &&
      c /= '"' &&
      c /= '.' &&
      c /= '?' &&
      c /= ',' &&
      c /= '\''

  | Parse the Saxon genitive ' or ' s. This is ran after parsing every
-- token, but is expected to fail most of the time.
genitive :: (Int, Int) -> Parser (Maybe (Token,(Int, Int)))
genitive pos =
  optional go
  where
    go =
      do _ <- char '\''
         ms <- peekChar
         case ms of
           Just 's' -> anyChar *> pure (Genitive pos True,second (+1) pos)
           _ -> pure (Genitive pos False,second (+1) pos)

-- | Like 'many', but retains the current source position and supports
-- postfix-parsing of the genitive apostrophe.
manyWithPos :: (Monad m, Alternative m)
            => ((t, t1) -> m (a, (t, t1))) -> ((t, t1) -> m (Maybe (a, (t, t1))))
            -> (t, t1) -> m ([a], (t, t1))
manyWithPos p p' pos =
  do r <- fmap (first Just) (p pos) <|> pure (Nothing,pos)
     case r of
       (Nothing,_) ->
         return ([],pos)
       (Just x,newpos@(!_,!_)) ->
         do r' <- p' newpos
            case r' of
              Nothing ->
                do (xs,finalpos) <- manyWithPos p p' newpos
                   return (x:xs,finalpos)
              Just (y,newpos') ->
                do (xs,finalpos) <- manyWithPos p p' newpos'
                   return (x:y:xs,finalpos)

  | Skip spaces ( space , newline , tab (= 4 spaces ) ) and keep
-- positioning information up to date.
spaces :: (Int,Int) -> Parser (Int,Int)
spaces (sline,scol) =
  go sline scol
  where
    go line col =
      do c <- peekChar
         case c of
           Just '\n' -> anyChar *> go (line+1) 0
           Just ' ' -> anyChar *> go line (col+1)
           Just '\t' -> anyChar *> go line (col+4)
           _ -> return (line,col)

# LANGUAGE BangPatterns #
 | The tokenizer.
 | Parse a token.
 | Parse a number.
 | Parse a quoted string, @\"foobar\"@.
 | Parse a period \".\".
 | Parse a question mark \"?\".
 | Parse a word, which is any sequence of non-whitespace words
 containing none of the other token characters.
 token, but is expected to fail most of the time.
 | Like 'many', but retains the current source position and supports
 postfix-parsing of the genitive apostrophe.
 positioning information up to date.
  | Tokenizer for ACE . Tokens retain source locations ( line and column ) .

module ACE.Tokenizer where

import           ACE.Types.Tokens

import           Control.Applicative
import           Control.Arrow
import           Control.Monad
import           Data.Attoparsec.Text hiding (number)
import           Data.Char
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read as T

  | Tokenize some complete ACE text .
tokenize :: Text -> Either String [Token]
tokenize =
  parseOnly (fmap fst tokenizer <* endOfInput)

tokenizer :: Parser ([Token],(Int,Int))
tokenizer =
  manyWithPos (spaces >=> token)
              genitive
              (1,0)

token :: (Int,Int) -> Parser (Token,(Int,Int))
token pos =
  number pos <|>
  quotedString pos <|>
  period pos <|>
  comma pos <|>
  questionMark pos <|>
  word pos

number :: (Int, Int) -> Parser (Token, (Int,Int))
number pos =
  fmap (\n -> (Number pos (either (const 0) fst (T.decimal n)),second (+ T.length n) pos))
       (takeWhile1 isDigit)

quotedString :: (Int,Int) -> Parser (Token,(Int,Int))
quotedString pos =
  char '"' *> (cons <$> takeWhile1 (/='"')) <* char '"'
  where
    cons x =
      (QuotedString pos x
      ,second (+ (T.length x + 2)) pos)

period :: (Int,Int) -> Parser (Token,(Int,Int))
period pos =
  char '.' *> pure (Period pos,second (+1) pos)

  | Parse a comma \",\ " .
comma :: (Int,Int) -> Parser (Token,(Int,Int))
comma pos =
  char ',' *> pure (Comma pos,second (+1) pos)

questionMark :: (Int,Int) -> Parser (Token,(Int,Int))
questionMark pos =
  char '?' *> pure (QuestionMark pos,second (+1) pos)

word :: (Int,Int) -> Parser (Token,(Int,Int))
word pos =
  cons <$> takeWhile1 wordChar
  where
    cons w = (Word pos w,second (+ T.length w) pos)
    wordChar c =
      not (isSpace c) &&
      c /= '"' &&
      c /= '.' &&
      c /= '?' &&
      c /= ',' &&
      c /= '\''

  | Parse the Saxon genitive ' or ' s. This is ran after parsing every
genitive :: (Int, Int) -> Parser (Maybe (Token,(Int, Int)))
genitive pos =
  optional go
  where
    go =
      do _ <- char '\''
         ms <- peekChar
         case ms of
           Just 's' -> anyChar *> pure (Genitive pos True,second (+1) pos)
           _ -> pure (Genitive pos False,second (+1) pos)

manyWithPos :: (Monad m, Alternative m)
            => ((t, t1) -> m (a, (t, t1))) -> ((t, t1) -> m (Maybe (a, (t, t1))))
            -> (t, t1) -> m ([a], (t, t1))
manyWithPos p p' pos =
  do r <- fmap (first Just) (p pos) <|> pure (Nothing,pos)
     case r of
       (Nothing,_) ->
         return ([],pos)
       (Just x,newpos@(!_,!_)) ->
         do r' <- p' newpos
            case r' of
              Nothing ->
                do (xs,finalpos) <- manyWithPos p p' newpos
                   return (x:xs,finalpos)
              Just (y,newpos') ->
                do (xs,finalpos) <- manyWithPos p p' newpos'
                   return (x:y:xs,finalpos)

  | Skip spaces ( space , newline , tab (= 4 spaces ) ) and keep
spaces :: (Int,Int) -> Parser (Int,Int)
spaces (sline,scol) =
  go sline scol
  where
    go line col =
      do c <- peekChar
         case c of
           Just '\n' -> anyChar *> go (line+1) 0
           Just ' ' -> anyChar *> go line (col+1)
           Just '\t' -> anyChar *> go line (col+4)
           _ -> return (line,col)
