{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, RankNTypes #-}

-- |
-- Module      : Text.Peggy.Prim
-- Copyright   : (c) Hideyuki Tanaka 2011
-- License     : BSD-style
--
-- Maintainer  : tanaka.hideyuki@gmail.com
-- Stability   : experimental
-- Portability : portable
--
-- The monadic parser type and combinators to construct
-- packrat parsers for code generator.
--

module Text.Peggy.Prim (
  -- * Parsing functions
  parse,
  parseString,
  parseFile,
  
  -- * The parser type
  Parser(..),
  -- * The (internal) result type
  Result(..),
  -- * The error type
  ParseError(..),
  -- * The cache type
  MemoTable(..),
  
  -- * Memoising combinator
  memo,
  
  -- * Position functions
  getPos,
  setPos,
  
  -- * Combinators
  anyChar,
  satisfy,
  char,
  string,
  
  expect,
  unexpect,
  
  -- * Utiligy
  space,
  defaultDelimiter,
  token,
  ) where

import Control.Applicative
import Control.Monad.ST
import Control.Monad.Error
import Data.Char
import Data.HashTable.ST.Basic as HT
import qualified Data.ListLike as LL

import Text.Peggy.SrcLoc

-- | Parsing function
parse :: MemoTable tbl
         => (forall s . Parser tbl str s a) -- ^ parser
         -> SrcPos                          -- ^ input information
         -> str                             -- ^ input string
         -> Either ParseError a             -- ^ result
parse p pos str = runST $ do
  tbl <- newTable
  res <- unParser p tbl pos ' ' str
  case res of
    Parsed _ _ _ ret -> return $ Right ret
    Failed err -> return $ Left err

-- | Parsing function with only input name
parseString :: MemoTable tbl
             => (forall s . Parser tbl str s a) -- ^ parser
             -> String                          -- ^ input name
             -> str                             -- ^ input string
             -> Either ParseError a             -- ^ result
parseString p inputName str =
  parse p (SrcPos inputName 0 1 1) str

-- | Parse from file
parseFile :: MemoTable tbl
             => (forall s . Parser tbl String s a) -- ^ parser
             -> FilePath                           -- ^ input filename
             -> IO (Either ParseError a)           -- ^ result
parseFile p fp =
  parse p (SrcPos fp 0 1 1) <$> readFile fp

--

newtype Parser tbl str s a
  = Parser { unParser :: tbl s -> SrcPos -> Char -> str -> ST s (Result str a) }

data Result str a
  = Parsed SrcPos Char str a
  | Failed ParseError

data ParseError
  = ParseError SrcLoc String
  deriving (Show)

instance Error ParseError

nullError :: ParseError
nullError = ParseError (LocPos $ SrcPos "" 0 1 1) ""

errMerge :: ParseError -> ParseError -> ParseError
errMerge e1@(ParseError loc1 msg1) e2@(ParseError loc2 msg2)
  | loc1 >= loc2 = e1
  | otherwise = e2

class MemoTable tbl where
  newTable :: ST s (tbl s)

instance Monad (Parser tbl str s) where
  return v = Parser $ \_ pos p s -> return $ Parsed pos p s v
  p >>= f = Parser $ \tbl pos prev s -> do
    res <- unParser p tbl pos prev s
    case res of
      Parsed qos q t x ->
        unParser (f x) tbl qos q t
      Failed err ->
        return $ Failed err

instance Functor (Parser tbl str s) where
  fmap f p = return . f =<< p

instance Applicative (Parser tbl str s) where
  pure = return
  p <*> q = do
    f <- p
    x <- q
    return $ f x

instance MonadError ParseError (Parser tbl str s) where
  throwError err = Parser $ \_ _ _ _ -> return $ Failed err
  catchError p h = Parser $ \tbl pos prev s -> do
    res <- unParser p tbl pos prev s
    case res of
      Parsed {} -> return res
      Failed err -> unParser (h err) tbl pos prev s

instance Alternative (Parser tbl str s) where
  empty = throwError nullError
  p <|> q =
    catchError p $ \perr ->
    catchError q $ \qerr ->
    throwError $ perr `errMerge` qerr

memo :: (tbl s -> HT.HashTable s Int (Result str a))
        -> Parser tbl str s a 
        -> Parser tbl str s a
memo ft p = Parser $ \tbl pos@(SrcPos _ n _ _) prev s -> do
  cache <- HT.lookup (ft tbl) n
  case cache of
    Just v -> return v
    Nothing -> do
      v <- unParser p tbl pos prev s
      HT.insert (ft tbl) n v
      return v

getPos :: Parser tbl str s SrcPos
getPos = Parser $ \_ pos prev str -> return $ Parsed pos prev str pos

setPos :: SrcPos -> Parser tbl str s ()
setPos pos = Parser $ \_ _ prev str -> return $ Parsed pos prev str ()

parseError :: String -> Parser tbl str s a
parseError msg =
  throwError =<< ParseError . LocPos <$> getPos <*> pure msg

anyChar :: LL.ListLike str Char => Parser tbl str s Char
anyChar = Parser $ \_ pos _ str ->
  if LL.null str
  then return $ Failed nullError
  else do
    let c  = LL.head str
        cs = LL.tail str
    return $ Parsed (pos `advance` c) c cs c

satisfy :: LL.ListLike str Char => (Char -> Bool) -> Parser tbl str s Char
satisfy p = do
  c <- anyChar
  when (not $ p c) $ throwError nullError
  return c

char :: LL.ListLike str Char => Char -> Parser tbl str s Char
char c = satisfy (==c) <|> parseError ("expect " ++ show c)

string :: LL.ListLike str Char => String -> Parser tbl str s String
string str = mapM char str <|> parseError ("expect " ++ show str)

expect :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s ()
expect p = do
  b <- test p
  when (not b) $ parseError "unexpected input"

unexpect :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s ()
unexpect p = do
  b <- test p
  when b $ parseError "unexpected input"

test :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s Bool
test p = Parser $ \tbl pos prev str -> do
  res <- unParser p tbl pos prev str
  return $ case res of
    Parsed _ _ _ _ -> Parsed pos prev str True
    Failed _ -> Parsed pos prev str False

space :: LL.ListLike str Char => Parser tbl str s ()
space = () <$ satisfy isSpace

defaultDelimiter :: LL.ListLike str Char => Parser tbl str s ()
defaultDelimiter = () <$ satisfy (\c -> isPunctuation c || c == '+')

getPrevChar :: LL.ListLike str Char => Parser tbl str s Char
getPrevChar = Parser $ \_ pos prev str ->
  return $ Parsed pos prev str prev  

token :: LL.ListLike str Char
         => Parser tbl str s ()
         -> Parser tbl str s ()
         -> Parser tbl str s a
         -> Parser tbl str s a
token sp del p = do
  many sp
  ret <- p
  prev <- getPrevChar
  sp <|> expect del <|> unexpect (satisfy $ check prev)
  many sp
  return ret
  where
    check pr cr
      | isAlnum' pr && isAlnum' cr = True -- error "alnum"
      | isDigit pr && isDigit cr = True -- error "digit"
      | isGlyph pr && isGlyph cr = True -- error ("glyph " ++ show pr ++ ", " ++ show cr)
      | otherwise = False
    
    isAlnum' c = isAlpha' c || isDigit c
    isAlpha' c = isAlpha c || c == '_'
    isGlyph c = isPrint c && not (isAlpha' c) && not (isDigit c)