content: {-# LANGUAGE FlexibleContexts #-}
  module Kalium.Pascal.Tokenize (tokenCC, Token(..)) where
  
  import Prelude
  import Data.Functor
  import Control.Monad
  
  import Data.Ratio
  import Data.Char (toLower, digitToInt)
  import qualified Data.HashMap.Strict as M
  
  import Text.Parsec
  
  data Token
      = KwVar
      | KwBegin
      | KwEnd
      | KwFor
      | KwTo
      | KwDo
      | KwFunction
      | KwProcedure
      | KwTrue
      | KwFalse
      | KwAnd
      | KwOr
      | KwXor
      | KwNot
      | KwDiv
      | KwMod
      | KwIf
      | KwThen
      | KwElse
      | KwCase
      | KwOf
      | KwArray
      | KwForward
      | LParen
      | RParen
      | Semicolon
      | Comma
      | Dot
      | DoubleDot
      | Plus
      | Minus
      | Assign
      | Asterisk
      | Slash
      | Colon
      | EqSign
      | Suck
      | Blow
      | SuckBlow
      | SuckEq
      | BlowEq
      | Name String
      | INumber Integer
      | FNumber Rational
      | Quote String
      | LSqBrace
      | RSqBrace
      | Unknown Char
      | EOF
      deriving (Eq, Show)
  
  type P u a = Parsec String u a
  
  tokenCC :: (Token -> P u a) -> P u a
  tokenCC cont = pToken' >>= cont
  
  pToken' :: P u Token
  pToken' = do pSkip
               pToken <|> pEOF <|> pUnknown
  
  pEOF :: P u Token
  pEOF = EOF <$ eof
  
  pUnknown :: P u Token
  pUnknown = Unknown <$> anyChar
  
  pToken :: P u Token
  pToken = choice [pPunct, pNumber, pName, pQuote] <?> "token"
  
  pPunct :: P u Token
  pPunct = choice
     [ char '(' >> choice
          [ char '.' $> LSqBrace
          , return LParen
          ]
     , char ')' $> RParen
     , char '[' $> LSqBrace
     , char ']' $> RSqBrace
     , char '+' $> Plus
     , char '-' $> Minus
     , char '*' $> Asterisk
     , char '/' $> Slash
     , char ',' $> Comma
     , char ';' $> Semicolon
     , char '=' $> EqSign
     , char '<' >> choice
          [ char '>' $> SuckBlow
          , char '=' $> SuckEq
          , return Suck
          ]
     , char '>' >> choice
          [ char '=' $> BlowEq
          , return Blow
          ]
     , char '.' >> choice
          [ char '.' $> DoubleDot
          , char ')' $> RSqBrace
          , return Dot
          ]
     , char ':' >> choice
          [ char '=' $> Assign
          , return Colon
          ]
     ]
  
  pSign :: P u Bool
  pSign = choice
        [ char '+' $> True
        , char '-' $> False
        , return True
        ]
  
  pNumber :: P u Token
  pNumber = do
      intSection <- many1 digit
      try (pFloat intSection)
          <|> return (INumber $ parseInt intSection)
  
  pFloat :: String -> P u Token
  pFloat intSection = do
      char '.'
      fracSection <- many1 digit
      try (pExp intSection fracSection)
          <|> return (FNumber $ parseFrac intSection fracSection)
  
  pExp :: String -> String -> P u Token
  pExp intSection fracSection = do
      char 'e' <|> char 'E'
      eSign <- pSign
      eSection <- many1 digit
      return (FNumber $ parseExp intSection fracSection eSign eSection)
  
  parseInt :: String -> Integer
  parseInt = foldl (\acc c -> fromIntegral (digitToInt c) + acc * 10) 0
  
  parseFrac :: String -> String -> Rational
  parseFrac intSection fracSection = parseInt (intSection ++ fracSection)
                                   % 10 ^ length fracSection
  
  parseExp :: String -> String -> Bool -> String -> Rational
  parseExp intSection fracSection eSign eSection
      = (if eSign then (*) else (/))
          (parseFrac intSection fracSection)
          (10 ^ parseInt eSection)
  
  pName :: P u Token
  pName = let gen p = char '_' <|> fmap toLower p
              ident = liftM2 (:) (gen letter) (many $ gen alphaNum)
          in fmap mangle ident
  
  mangle :: String -> Token
  mangle cs = maybe (Name cs) id (M.lookup cs keywords)
  
  keywords :: M.HashMap String Token
  keywords = M.fromList
      [ ("var"     , KwVar)
      , ("begin"   , KwBegin)
      , ("end"     , KwEnd)
      , ("for"     , KwFor)
      , ("to"      , KwTo)
      , ("do"      , KwDo)
      , ("function", KwFunction)
      , ("procedure", KwProcedure)
      , ("true"    , KwTrue)
      , ("false"   , KwFalse)
      , ("and"     , KwAnd)
      , ("or"      , KwOr)
      , ("xor"     , KwXor)
      , ("not"     , KwNot)
      , ("div"     , KwDiv)
      , ("mod"     , KwMod)
      , ("if"      , KwIf)
      , ("then"    , KwThen)
      , ("else"    , KwElse)
      , ("case"    , KwCase)
      , ("of"      , KwOf)
      , ("array"   , KwArray)
      , ("forward" , KwForward)
      ]
  
  pQuote :: P u Token
  pQuote = fmap Quote (char qmark >> quote') where
      qmark  = '\''
      quote' = anyChar >>= next
      next c | c == qmark = liftM2 (:) (char qmark) quote' <|> return ""
             | otherwise  = liftM2 (:) (return c)   quote'
  
  pSkip :: P u ()
  pSkip = skipMany (void space <|> pComment)
  
  pComment :: P u ()
  pComment = void comment <?> "comment"
           where comment = open >> manyTill anyChar close
                 open  = void (char '{') <|> void (try $ string "(*")
                 close = void (char '}') <|> void (try $ string "*)")
  