module TermParser where

import qualified Text.ParserCombinators.Parsec.Token as T
import qualified Text.ParserCombinators.Parsec.Language as L
import qualified Text.ParserCombinators.Parsec as Parsec
import Text.ParserCombinators.Parsec ( CharParser, Parser, (<|>) )
import Text.ParserCombinators.Parsec.Expr
           ( Assoc(AssocLeft, AssocRight, AssocNone) )

import Control.Monad ( liftM2 )
import Control.Functor.HT ( void )



lexer :: T.TokenParser st
lexer =
    T.makeTokenParser $ L.emptyDef {
        L.commentStart = "{-",
        L.commentEnd = "-}",
        L.commentLine = "--",
        L.nestedComments = True,
        L.identStart = identifierStart,
        L.identLetter = identifierLetter,
        L.opStart = operatorStart,
        L.opLetter = operatorLetter,
        L.caseSensitive = True,
        L.reservedNames = [ "module", "where", "import", "qualified"
                          , "as", "data", "class", "instance", "case", "of"
                          , "infix", "infixl", "infixr" ],
        L.reservedOpNames = [ "=", "::", "|" ]
    }



{-
FIXME: This should be read from a file (Prelude.hs).
But then we need a parser that correctly handles fixity information on-the-fly.
A simplified solution could be:
Allow fixity definitions only between import and the first declaration.
With this restriction we could parse the preamble first
and then start with a fresh parser for the module body.
For now, we hard-code Prelude's fixities:


infixr 9  .
infixr 8  ^, ^^, **
infixl 7  *, /, `quot`, `rem`, `div`, `mod`
infixl 6  +, -

-- The (:) operator is built-in syntax, and cannot legally be given
-- a fixity declaration; but its fixity is given by:
--   infixr 5  :

infix  4  ==, /=, <, <=, >=, >
infixr 3  &&
infixr 2  ||
infixl 1  >>, >>=
infixr 1  =<<
infixr 0  $, $!, `seq`
-}

operators :: [[([Char], Assoc)]]
operators =
    [ [ ( ".", AssocRight ), ( "!!", AssocLeft ) ]
    , [ ( "^", AssocRight) ]
    , [ ( "*", AssocLeft), ("/", AssocLeft), ("%", AssocLeft), ("+:+", AssocRight) ]
    , [ ( "+", AssocLeft), ("-", AssocLeft), ("=:=", AssocRight) ]
    , [ ( ":", AssocRight ), ( "++", AssocRight ) ]
    , map ( \ s -> (s, AssocNone) ) [ "==", "/=", "<", "<=", ">=", ">" ]
    , [ ( "&&", AssocRight ) ]
    , [ ( "||", AssocRight ) ]
    , [ ( "$",  AssocRight ) ]
    ]

identifierStart, identifierLetter :: CharParser st Char
identifierStart = Parsec.letter <|> Parsec.char '_'

-- FIXME: check the distinction between '.' in qualified names, and as operator
identifierLetter =
    Parsec.alphaNum <|> Parsec.char '_' <|> Parsec.char '.'

identifier :: Parser String
identifier =
    liftM2 (:) identifierStart (Parsec.many identifierLetter)


operatorStart, operatorLetter :: CharParser st Char
operatorStart  = Parsec.oneOf operatorSymbols
operatorLetter = Parsec.oneOf operatorSymbols

operatorSymbols :: [Char]
operatorSymbols = ":!#$%&*+./<=>?@\\^|-~"


symbol :: String -> Parser ()
symbol = void . T.symbol lexer