{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE NoMonomorphismRestriction  #-}
{-# OPTIONS -Wall                       #-}

module UUParsingSimple (
  Parser,
  Symbol(..),
  Alternative(..),
  Applicative(..),
  ExtApplicative(..),
  (<$>),
  (<<|>),
  pReturn,
  pFail,
  pToken,
  pList,
  pList1,
  pListSep,
  pEither,
  opt,
  (<++>),
  pMaybe,
  pDigitChar,
  pDigitChars,
  pDigit,
  pNat,
  pInt,
  pLower,
  pUpper,
  pAlpha,
  pChar,
  pOp,
  pChainl,
  pChainr,
  sepBy,
  pAny,
  pAnySym,
  pAscii,
  pIdChar,
  pLowerId,
  pUpperId,
  pPacked,
  pBracketing,
  pParens,
  pBrackets,
  pBraces,
  exec,
  runM,
  run,
) where

import Control.Monad.Identity
import Data.Char

import Text.ParserCombinators.UU.Parsing hiding (pList, pList1, pListSep, opt, pMaybe, pEither, pToken, pReturn, pFail, pPacked, pChainl, pChainr, pAny, pAnySym, (<<|>))
import qualified Text.ParserCombinators.UU.Parsing as UU (pList, pList1, pListSep, opt, pMaybe, pEither, pToken, pReturn, pFail, pPacked, pChainl, pChainr, pAny, pAnySym, (<<|>))

--------------------------------------------------------------------------------

-- | A parser is effectively a function from a stream of symbols to a result and
-- errors. Here, we choose a stream of characters.

type Parser result = P (Str Char) result 

--------------------------------------------------------------------------------
-- General parser combinators

{-

-- These are used exactly as imported. See this file for examples.

-- | Parse symbols

pSym :: (Symbol p symbol token) => symbol -> p token

-- | Choose an alternative that succeeds. See Control.Applicative.

(<|>) :: (Alternative f) => f a -> f a -> f a
infixl 3 <|>

-}

-- | Choose the left alternative if it succeeds; otherwise, choose the right
-- alternative. This is useful if both parsers may succeed, but you always want
-- the first one.

(<<|>) :: Parser a -> Parser a -> Parser a
(<<|>) = (UU.<<|>)
infixl 3 <<|>

{-

-- | Apply a function in a functor to a functor argument to get a new functor
-- argument. See Control.Applicative.

(<*>) :: (Applicative f) => f (a -> b) -> f a -> f b
infixl 4 <*>

-- | Parse left and right values, but return only the result of the left

(<*) :: (ExtApplicative p) => p a -> p b -> p a
infixl 4 <*

-- | Parse left and right values, but return only the result of the right

(*>) :: (ExtApplicative p) => p b -> p a -> p a
infixl 4 *>

-- | Same as 'fmap'. See Control.Applicative.

(<$>) :: (Functor f) => (a -> b) -> f a -> f b
infixl 4 <$>

-- | Parse the second argument, but return the first argument as the result of a
-- parser

(<$) :: (ExtApplicative p) => a -> p b -> p a
infixl 4 <$

-}

--------------------------------------------------------------------------------
-- Basic parsers

-- | A parser that always succeeds by "embedding" the argument into a Parser

pReturn :: a -> Parser a
pReturn = UU.pReturn

-- | A parser that always fails

pFail :: Parser a
pFail = UU.pFail

-- | Parse a string token

pToken :: String -> Parser String
pToken = UU.pToken

-- | Parse repeatedly, may be empty

pList :: Parser a -> Parser [a]
pList = UU.pList

-- | Parse repeatedly with at least one successful parse

pList1 :: Parser a -> Parser [a]
pList1 = UU.pList1

-- | Parse repeatedly with a separator (first argument)

pListSep :: Parser b -> Parser a -> Parser [a]
pListSep = UU.pListSep

-- | Parse and tag the value of the parser that succeeds

pEither :: Parser a -> Parser b -> Parser (Either a b)
pEither = UU.pEither

-- | Parse and tag the value of the parser if it succeeds. If it fails, return
-- 'Nothing'.

pMaybe :: Parser a -> Parser (Maybe a)
pMaybe = UU.pMaybe

-- | Optionally recognize parser p. If p can be recognized, the return value of
-- p is used. Otherwise, the value v is used.

opt :: Parser a -> a -> Parser a
opt = UU.opt
infixl 2 `opt`

-- | Concatenate results of strings

(<++>) :: Parser [a] -> Parser [a] -> Parser [a]
p <++> q = (++) <$> p <*> q

--------------------------------------------------------------------------------
-- Digits

-- | Parse a digit character

pDigitChar :: Parser Char
pDigitChar = pSym ('0', '9')

-- | Parse digit characters

pDigitChars :: Parser String
pDigitChars = pList1 pDigitChar

-- | Parse digit as Int

pDigit :: Parser Int
pDigit = toInt <$> pDigitChar 
  where
    toInt a = ord a - ord '0'

-- | Parse digits as non-negative integer (a "natural number")

pNat :: Parser Int
pNat = foldl (\a b -> a * 10 + b) 0 <$> pList1 pDigit

-- | Parse digits as possibly negative integer

pInt :: Parser Int
pInt = (negate <$ pSym '-' `opt` id) <*> pNat

--------------------------------------------------------------------------------
-- Letters

-- | Parse a lowercase letter

pLower :: Parser Char
pLower = pSym ('a', 'z')

-- | Parse an uppercase letter

pUpper :: Parser Char
pUpper = pSym ('A', 'Z')

-- | Parse an alphabetic letter

pAlpha :: Parser Char
pAlpha = pUpper <|> pLower

-- | Parse any character (includes unprintable characters)

pChar :: Parser Char
pChar = pSym (minBound :: Char, maxBound :: Char)

--------------------------------------------------------------------------------
-- Operators and chaining

-- | Parse an operator, giving the character symbol and the parser

pOp :: Char -> a -> Parser a
pOp c p = p <$ pSym c

-- | Parse a sequence of values separated by a left-associative operator

pChainl :: Parser (a -> a -> a) -> Parser a -> Parser a
pChainl = UU.pChainl

-- | Parse a sequence of values separated by a right-associative operator

pChainr :: Parser (a -> a -> a) -> Parser a -> Parser a
pChainr = UU.pChainr

-- | Convenient infix version of 'pChainl'

sepBy :: Parser a -> Parser (a -> a -> a) -> Parser a
sepBy = flip pChainl

--------------------------------------------------------------------------------
-- Any symbols

-- | Parse using any of the parsers in the list

pAny :: (a -> Parser b) -> [a] -> Parser b
pAny = UU.pAny

-- | Parse any of a list of characters

pAnySym :: [Char] -> Parser Char
pAnySym = UU.pAnySym

--------------------------------------------------------------------------------
-- Identifiers

-- | Parse a symbol in the ASCII character set

pAscii :: Parser Char
pAscii = pSym ('\000', '\254')

-- | Parse an identifier character

pIdChar :: Parser Char
pIdChar = pLower <|> pUpper <|> pDigitChar <|> pAnySym "='"

-- | Parse an identifier whose first letter is lowercase

pLowerId :: Parser String
pLowerId = (:) <$> pLower <*> pList pIdChar

-- | Parse an identifier whose first letter is uppercase

pUpperId :: Parser String
pUpperId = (:) <$> pUpper <*> pList pIdChar

--------------------------------------------------------------------------------
-- Packing and bracketing

-- | Parse left and right symbols on either side of a parsed value

pPacked :: Parser l -> Parser r -> Parser a -> Parser a
pPacked = UU.pPacked

-- | Parse character symbols around another parsed value

pBracketing :: Char -> Char -> Parser a -> Parser a
pBracketing l r = pPacked (pSym l) (pSym r)

-- | Parse parentheses around another parsed value

pParens :: Parser a -> Parser a
pParens = pBracketing '(' ')'

-- | Parse square brackets around another parsed value

pBrackets :: Parser a -> Parser a
pBrackets = pBracketing '[' ']'

-- | Parse curly braces around another parsed value

pBraces :: Parser a -> Parser a
pBraces = pBracketing '{' '}'

--------------------------------------------------------------------------------
-- Using parsers

-- | Execute a parser on a list of symbols and return a result and a (possibly
-- empty) list of errors.

exec :: Parser a -> String -> (a, [Error Char Char Int])
exec p = parse ((,) <$> p <*> pEnd) . listToStr

-- | Run a parser: if it succeeds and consumes the entire input, return the
-- result; otherwise fail by reporting unconsumed tokens.

runM :: (Monad m) => Parser a -> String -> m a
runM p i = do
  let (a, b) = exec p i
  if null b then return a else fail (show b)

-- | Same as 'runM' but is non-monadic and fails with an error.

run :: Parser a -> String -> a
run p = runIdentity . runM p