{-# LANGUAGE RankNTypes, KindSignatures, BangPatterns #-}

{-|
All you need to parse lambdaBase.
-}
module Language.LambdaBase.Parser (parseExpr, name, operatorChars, fixityOf) where

import Text.ParserCombinators.Parsec
import Language.LambdaBase.Core

import Data.List

{-|
Parse a valid name
-}
name = many1 $ oneOf "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890_*+-!@#$%?&=<>^|/.:"

{-|
What is a valid char for an operator.
-}
operatorChars = "_*+-!@#$%?&=<>^|/.:"

{-|
Easy function to parse a string.
-}
parseExpr :: String -> Either ParseError (Expr a)
parseExpr s = parse expr "" s

exprSep = do
    spaces
    optional $ do
        comment
        spaces
    return ()

comment = do
    choice [
        try inlineComment ,
        try lineComment
      ]

lineComment = do
    string "--"
    n <- many $ noneOf "\n"
    return ()

inlineComment = do
    string "{-"
    n <- many $ do
        choice [
            try (string "-" >> (notFollowedBy $ string "}") >> (return 'a'))
            , noneOf "-"
          ]
    string "-}"
    return ()

enclosed start end = do
    string start
    optional spaces
    n <- expr
    optional spaces
    string end
    return n

enclosedLine start end = do
    string start
    optional $ many1 $ char ' '
    n <- exprLine
    optional $ many1 $ char ' '
    string end
    return n

isOperator :: String -> Bool
isOperator n = and . map (\x -> any (==x) operatorChars) $ n

{-|
Will be infix if the string is an operator
-}
fixityOf :: String -> Fix
fixityOf n = if isOperator n then Infix else Prefix

nameNaked = do
    n <- name
    return $ Name n Naked $ fixityOf n

infixName = do
    (Name s d f) <- notNakedName "`" "`"
    return $ case fixityOf s of
        Infix  -> Name s d Prefix
        Prefix -> Name s d Infix

nameExpr = do
    choice [
        try nameNaked ,
        try infixName ,
        try $ notNakedName "{"  "}" ,
        try $ notNakedName ","  "," ,
        try $ notNakedName "\"" "\"" ,
        try $ notNakedName "'"  "'" ,
        try $ notNakedName "~"  "~" ,
        try $ notNakedName "["  "]"
      ]

notNakedName o c = do
    string o
    content <- many $ noneOf c
    string c
    return $ Name content (Delimited o c) Prefix

lambda = do
    string "\\"
    spaces
    n <- name
    spaces
    evsS <- choice [string "->", string "~>"]
    let evs = case evsS of
                   "->" -> Strict
                   "~>" -> Lazy
    exprSep
    content <- expr
    return $ Lambda (Arg n evs) content Prefix

indentedExpr indent = do
    ind <- string indent
    ex <- choice [ try $ enclosedLine "" "\n" , try exprSimple ]
    return ex

simpleDoBlock = do
    n <- many $ char ' '
    string "do "
    nil <- exprSimple
    string " "
    cons <- exprSimple
    string "\n"
    string n
    plusIndent <- many1 $ char ' '
    let idSt = take ( length n + length plusIndent ) $ repeat ' '
    firstEx <- exprLine
    string "\n"
    rest <- many (choice [ try simpleDoBlock , try $ indentedExpr idSt ] )
    return $
        Expr (
            (Lambda (Arg "nil" Strict) (
                Lambda (Arg "<->" Strict) (
                    Expr (
                        intersperse (Name "<->" Naked Infix) (  ( Name "nil" Naked Prefix ):firstEx:rest  )
                      ) Prefix
                  ) Prefix
              ) Prefix)
            : nil : cons : []
          ) Prefix

exprSimple = do
    choice [
        try simpleDoBlock ,
        try $ enclosed "(" ")" ,
        try nameExpr ,
        try lambda
      ]

exprLine = do
    optional $ many $ char ' '
    exprs <- sepEndBy1 exprSimple (many1 $ char ' ')
    optional $ many $ char ' '
    return $ Expr exprs Prefix

expr = do
    optional spaces
    exprs <- sepEndBy1 exprSimple exprSep
    optional spaces
    return $ Expr exprs Prefix