{-# LANGUAGE LambdaCase #-}

module Parser where
import Expr
import Utils

import Data.Char

---------------- Parser declerations ---------------------------


newtype Parser a = P (String -> [(a,String)])

apply :: Parser a -> String -> [(a,String)]
apply (P p) = p

instance Functor Parser where
  -- fmap :: (a -> b) -> Parser a -> Parser b
  fmap g p = P (\s -> case apply p s of
                        []        -> []
                        [(v,out)] -> [(g v, out)])


instance Applicative Parser where
  -- pure :: a -> Parser a
  pure v = P (\inp -> [(v,inp)])

  -- <*> :: Parser (a -> b) -> Parser a -> Parser b
  pg <*> px = P (\inp -> case apply pg inp of
                           []        -> []
                           [(g,out)] -> apply (fmap g px) out)

instance Monad Parser where
  -- (>>=) :: Parser a -> (a -> Parser b) -> Parser b
  p >>= f = P (\s -> case apply p s of
                       [] -> []
                       [(v, out)] -> apply (f v) out)

(<|>) :: Parser a -> Parser a -> Parser a
p <|> q = P (\s -> let ps = apply p s in
                     if null ps
                       then apply q s
                       else ps)

item :: Parser Char
item = P (\x -> case x of
            []     -> []
            (x:xs) -> [(x,xs)])


none :: Parser [a]
none = return []

sat :: (Char -> Bool) -> Parser Char
sat p = do x <- item
           if p x then return x else parse_fail

parse_fail :: Parser a
parse_fail = P (const [])


char :: Char -> Parser Char
char x = sat (== x)

string :: String -> Parser ()
string []     = return ()
string (x:xs) = do char x
                   string xs
                   return ()

some, many :: Parser a -> Parser [a]

some a = do c <- a
            cs <- many a
            return (c:cs)

many = optional . some

optional :: Parser [a] -> Parser [a]
optional = (<|> none)

spaces :: Parser [Char]
spaces = many (sat isSpace)

token :: Parser a -> Parser a
token = (spaces >>)

guard True = return ()
guard False = parse_fail

paren :: Parser a -> Parser a
paren p = do symbol "("
             c <- p
             symbol ")"
             return c

symbol :: String -> Parser ()
symbol = token . string

somewith, manywith :: Parser a -> Parser b -> Parser [b]
somewith s p = do c <- p
                  cs <- many (s >> p)
                  return (c:cs)

manywith s = optional . somewith s


digit :: Parser Int
digit = sat isDigit >>= \d -> return (cvt d)
  where cvt d = fromEnum d - fromEnum '0'


natural, nat :: Parser Int

natural = token nat
nat = do ds <- some digit
         return (foldl1 shiftl ds)
  where shiftl m n = 10*m+n

upto :: Char -> Parser String
upto c = P (\s -> let (xs, ys) = break (==c) s in
  if null ys then []
    else [(xs, tail ys)])

-- TODO look into why this didn't work
-- upto x = do c <- (sat (/= x))
--             cs <- upto x
--             return (c:cs)


----------------- Calculator -----------------------------------

-- Main parsing

{-
Example:
map (f . g) . foo f g . (bar * bar)

-}

expr :: Parser Expr
expr = simple >>= rest
  where
    rest l = do op <- operator
                r <- simple
                return (Compose [Con op [l, r]])
       <|> return l

operator :: Parser String
operator = do op <- token (some (sat symbolic))
              guard (op /= "." && op /= "=")
              return op

simple :: Parser Expr
simple = do es <- somewith (symbol ".") term
            return (Compose (concatMap deCompose es))

deCompose :: Expr -> [Atom]
deCompose (Compose at) = at

term :: Parser Expr
term = ident args <|> paren expr
args = many (ident none <|> paren expr)

ident :: Parser [Expr] -> Parser Expr
ident args =
  do x <- token (some (sat isAlphaNum))
     guard (isAlpha (head x))
     if isVar x
       then return (Compose [Var x])
       else if (x == "id")
       then return (Compose [])
              else do as <- args
                      return (Compose [Con x as])

isVar [x] = True
isVar [x,d] = isDigit d
isVar _ = False