{-# LANGUAGE TypeSynonymInstances #-}

module Parse where
import Lang
import Control.Applicative
import Control.Monad
import Data.Char
import Data.List



{- Note: Much of this is taken from UCSD cse230 lecture notes.
        Some of it I figured out on my own, but a lot of it is thanks
        to those notes.
https://cseweb.ucsd.edu/classes/wi12/cse230-a/lectures/parsers.html-}

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

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


{- takes two parsers, does one after the other-}
pairP ::  Parser a -> Parser b -> Parser (a,b)
pairP (P p1) (P p2) = P (\cs ->
        [((x,y),cs'') | (x,cs')  <- (p1 cs),
                        (y,cs'') <- (p2 cs')])

{- Return is the "identity parser"-}
identP :: a -> Parser a
identP x = P (\cs -> [(x,cs)])

{- so, we need to suck the a values out of
the first parser and invoke the second parser
with them on the remaining part of the string. -}
{- That makes sense... -}
composeP :: Parser a -> (a -> Parser b) -> Parser b
composeP pa f = P (\cs ->
        [(y,cs'') | (x,cs') <- parse pa cs,
                    (y,cs'') <- parse (f x) cs'])

fmapP :: (a -> b) -> Parser a -> Parser b
fmapP f p = P (\cs ->
        [(f x, cs')| (x,cs') <- parse p cs])

seqP :: Parser (a -> b) -> Parser a -> Parser b
seqP pf pa = P (\cs ->
        [(y,cs'') | (x,cs') <- parse pf cs,
                    (y,cs'') <- parse (fmapP x pa) cs'])

instance Functor Parser where
        fmap = fmapP

instance Applicative Parser where
        pure = identP
        (<*>) = seqP

{- do means return a parser that does these things -}
instance Monad Parser where
        (>>=) = composeP
        return = identP

failToParse :: Parser a
failToParse = P (\s -> [])


altParse :: Parser a -> Parser a -> Parser a
altParse p1 p2 = P (\cs -> let v = parse p1 cs in
                               if null v then parse p2 cs else v)

instance Alternative Parser where
        (<|>) = altParse
        empty = failToParse

instance MonadPlus Parser where
        mplus = altParse
        mzero = failToParse

singleChar :: Parser Char
singleChar = P (\s -> case s of
                      [] -> []
                      c : cs -> [(c,cs)])

parseIf :: (a -> Bool) -> Parser a -> Parser a
parseIf pred pa = P (\cs ->
        [(x,cs') | (x,cs') <- filter (pred . fst) $ parse pa cs])

digAsChar :: Parser Char
digAsChar = parseIf isDigit singleChar


tryBothParse :: Parser a -> Parser a -> Parser a
tryBothParse p1 p2 = P (\cs -> (parse p1 cs) ++ (parse p2 cs))


zeroOrOne :: Parser a -> a -> Parser a
zeroOrOne p base = tryBothParse p $ P (\cs -> [(base,cs)])

parseWord :: String -> Parser String
parseWord str = P (\cs -> if (Data.List.isPrefixOf str cs)
                           then [(str,drop (length str) cs)]
                           else [])

nat :: Parser Int
nat = do
        cs <- some digAsChar
        return $ read cs

letter :: Parser Char
letter = parseIf (\c -> any (==c) $ ['a'..'z'] ++ ['A'..'Z']) singleChar

parseChar :: Char -> Parser Char
parseChar c = parseIf (==c) singleChar

space :: Parser Char
space = parseChar ' '

nonSpace :: Parser Char
nonSpace = parseIf (/=' ') singleChar

openParen :: Parser Char
openParen = parseChar '('

closeParen :: Parser Char
closeParen = parseChar ')'

equal :: Parser Char
equal = parseChar '='

neg :: Parser Char
neg = parseChar '-'

notParse :: Parser Char
notParse = parseChar '!'


{- Zero or more -}
possible :: Parser a -> Parser [a]
possible = many

binOp :: Parser BOp
binOp = do
        op <- some nonSpace
        return $ bopRead op

monOp :: Parser MOp
monOp = do
        op <- neg <|> notParse
        return $ mopRead $ return op

validIdentChars :: [Char]
validIdentChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['_','\'']

identChar :: Parser Char
identChar = parseIf (\c -> any (==c) validIdentChars) singleChar

invalidIdents :: [String]
invalidIdents = ["if","let","susp","force"]

isValidIdent :: String -> Bool
isValidIdent x = not $ any (==x) invalidIdents

ident :: Parser Expr
ident = do
        ide <- some identChar
        guard $ isValidIdent ide
        return $ Ident ide

booleanValue :: Parser String
booleanValue = parseIf (\s -> s == "True" || s == "False") (some letter)

bool :: Parser Lit
bool = do
        b <- booleanValue
        return $ litRead b

int :: Parser Lit
int = do
        x <- zeroOrOne neg '∅'
        i <- nat
        return $ LInt $ if (x == '∅') then i else -i

lit :: Parser Lit
lit = int <|> bool

litExpr :: Parser Expr
litExpr = do
        _ <- many space
        l <- lit
        _ <- many space
        return $ Lit l

force :: Parser Expr
force = do
        many space
        parseWord "force"
        openParen
        many space
        e <- parseExpr
        many space
        closeParen
        many space
        return $ Force e

susp :: Parser Expr
susp = do
        many space
        parseWord "susp"
        openParen
        many space
        e <- parseExpr
        many space
        closeParen
        many space
        return $ Susp e

lam :: Parser Expr
lam = do
        many space
        openParen
        many space

        parseWord "\\"
        (Ident x) <- ident
        space
        parseWord "->"
        space
        e <- parseExpr

        many space
        closeParen
        many space
        return $ Lam x e

app :: Parser Expr
app = do
        many space
        openParen
        e <- parseExpr
        many space
        e' <- parseExpr
        closeParen
        many space
        return $ App e e'

bopExpr :: Parser Expr
bopExpr = do
        many space
        openParen
        many space
        e0 <- parseExpr
        many space
        b <- binOp
        many space
        e1 <- parseExpr
        many space
        closeParen
        many space
        return $ BinOp b e0 e1

mopExpr :: Parser Expr
mopExpr = do
        many space
        m <- monOp
        e <- parseExpr
        many space
        return $ MonOp m e

letExpr :: Parser Expr
letExpr = do
        many space
        parseWord "let"
        many space
        (Ident x) <- ident
        many space
        equal
        many space
        e <- parseExpr
        many space
        parseWord "in"
        many space
        e' <- parseExpr
        many space
        return $ Let (Bind x e) e'

ifExpr :: Parser Expr
ifExpr = do
        many space
        parseWord "if"
        many space
        c <- parseExpr
        many space
        parseWord "then"
        many space
        et <- parseExpr
        many space
        parseWord "else"
        many space
        ef <- parseExpr
        many space
        return $ If c et ef

parseExpr :: Parser Expr
parseExpr = do
        e <- ident
         <|> litExpr
         <|> susp
         <|> force
         <|> lam
         <|> app
         <|> bopExpr
         <|> mopExpr
         <|> letExpr
         <|> ifExpr
        return e

