import Text.ParserCombinators.Parsec

-- Data Types

type Position = (Int,Int)

data PState = PState Position

data Token body = Token Position body

data ApplyFunction = ApplyFunction Expr Expr

data Bracket = Bracket Expr

data Expr = AtomicExpr String
          | ApplyFunctionExpr ApplyFunction | BracketExpr Bracket

instance (Show body) => Show (Token body) where
    show (Token (line,column) body)
        = show line++","++show column++" "++show body

instance Show ApplyFunction where
    show (ApplyFunction func param)
        = "["++show func++" "++show param++"]"

instance Show Bracket where
    show (Bracket expr)
        = "("++show expr++")"

instance Show Expr where
    show (AtomicExpr str)
        = str
    show (ApplyFunctionExpr expr)
        = show expr
    show (BracketExpr expr)
        = show expr

-- Position

nextPos :: String -> Position -> Position
nextPos str pos = foldl countUpPos pos str
    where
        countUpPos (line,column) '\n' = (line+1,0)
        countUpPos (line,column) _ = (line,column+1)

-- Tokenizer

parseToken :: (String -> t)
    -> (GenParser Char PState String)
    -> (GenParser Char PState (Token t))
parseToken func strParser
    = do string <- strParser
         (PState currentPos) <- getState
         whitespace <- spacesAndComments
         setState (PState (nextPos (string++whitespace) currentPos))
         return (Token currentPos (func string))

spaceToken :: GenParser Char PState String
spaceToken = many1 space

lineCommentToken :: GenParser Char PState String
lineCommentToken
    = do try (string "--")
         body <- manyTill anyChar
             (((char '\n')>>=(\_ -> return ())) <|> eof)
         return ("--"++body++"\n")

blockCommentToken :: GenParser Char PState String
blockCommentToken
    = do string "{-"
         body <- manyTill anyChar (try (string "-}"))
         return ("{-"++body++"-}")

spacesAndComments :: GenParser Char PState String
spacesAndComments
    = do body <- many (spaceToken <|> lineCommentToken <|> blockCommentToken)
         return $ concat body

symbolToken :: GenParser Char PState (Token String)
symbolToken = parseToken id
    (many1 (oneOf "!#$%&*+-./:<=>?@^"))

nameToken :: GenParser Char PState (Token String)
nameToken  = parseToken id
    (do c <- (letter <|> char '_')
        cs <- many (alphaNum <|> char '_')
        return (c:cs))

numberToken :: GenParser Char PState (Token String)
numberToken = parseToken id
    (do integer <- many1 digit
        do char '.'
           fractional <- many1 digit
           return (integer++"."++fractional)
         <|> (return integer))

eofToken :: GenParser Char PState (Token ())
eofToken = parseToken (const ())
    (do eof
        return "")

-- Parser

exprParser :: GenParser Char PState Expr
exprParser = applyFunctionParser

toplevelExprParser :: GenParser Char PState Expr
toplevelExprParser
    = (bracketParser>>=(return.BracketExpr))
      <|> (nameToken>>=(\(Token pos body) -> return $ AtomicExpr body))
      <|> (numberToken>>=(\(Token pos body) -> return $ AtomicExpr body))

applyFunctionParser :: GenParser Char PState Expr
applyFunctionParser
    = chainl1 toplevelExprParser $ return (\l r -> ApplyFunctionExpr $ ApplyFunction l r)

bracketParser :: GenParser Char PState Bracket
bracketParser
    = do parseToken (const ()) (string "(")
         body <- applyFunctionParser
         parseToken (const ()) (string ")")
         return $ Bracket body

myParseFromFile p s filename
    = do input <- readFile filename
         return (runParser p s filename input)

myParseTest filename
    = do result <- myParseFromFile
             exprParser (PState (0,0)) filename
         case result of
             Left err -> print err
             Right result -> print result