{-# LANGUAGE CPP #-}
module Language.CalDims.Expression 
	( parseExpr
	, parseName
	, parseExistingName
	, parseBindE
	, parseEinh
	, parseBind
	, brackets
	, parseNonRecursiveExpr
	, parseColon
	, parseComma
	, flush) where

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Prim
import Text.ParserCombinators.Parsec.Expr
import Ratio ((%))
import Control.Monad.Error
import Control.Monad.State
import Control.Monad
import qualified Data.Map as Map

#ifdef DEBUG
import Debug.Trace
#endif

import Language.CalDims.Expr ()
import Language.CalDims.Types
import Language.CalDims.Action
import Language.CalDims.State as State
import Language.CalDims.Helpers

requireEntry :: Name -> MyParser StateEntry
requireEntry n = do
	state <- getState
        case Map.lookup n (getScope state) of
                Nothing -> fail $ "No such object: " ++ pretty n
                Just sth -> return sth

hnn, hasNotName :: Expr -> Name -> MyParser Bool
#ifdef DEBUG
hasNotName e n = do
	res <- hnn e n
	return $ trace (show e ++ " `hasNotName` " ++ show n ++ " -> " ++ show res) res
#else
hasNotName = hnn
#endif

(Bin _ e1 e2) `hnn` n = (e1 `hasNotName` n) #&&# (e2 `hasNotName` n)
(Uni _ e) `hnn` n = e `hasNotName` n
(ArgRef _) `hnn` _ = return True
(Call fn args) `hnn` n = do
	e_ <- requireEntry fn
	case e_ of
		Function _ e -> (return (fn /= n)) #&&# (liftM and) (sequence  (map (`hasNotName` n) args)) #&&# (e `hasNotName` n)
		_ -> return True -- call to builtin

(Evaled (_, Dims m)) `hnn` n = do
        state <- getState
        let exprs = Map.elems $ Map.mapMaybeWithKey (\k v -> if_ 
		(k `Map.member` m) 
		(case v of Dimension e -> Just e; _ -> Nothing) 
		Nothing) (getScope state)
        (return $ not (n `Map.member` m)) #&&# (liftM and) (sequence (map (`hasNotName` n) exprs))

flush :: GenParser Char State.State (IO(), State.State)
flush = do
        many $ noneOf []
        eof
        s <- getState
        return (return (), s)

binary :: String -> (Expr -> Expr -> Expr) -> Assoc -> Operator Char State.State Expr
binary s f assoc = Infix (do
	string s
	spaces
	return f) assoc

parseExpr :: MyParser Expr
parseExpr  = do
	buildExpressionParser table factor
        <?> "expression"

parseNonRecursiveExpr :: Name -> MyParser Expr
parseNonRecursiveExpr n = do
	e <- parseExpr
	t <- e `hasNotName` n
	case t of
		True -> return e
		False -> fail "No recursion supported."

table :: OperatorTable Char State.State Expr
table  = [
	  [Prefix (do
		parseMinus
		return $ Uni Negate)],
          [binary "^" (Bin Exp) AssocRight],
          [Postfix (do 
		d <- parseEinh
		return $ mulMerge (Evaled (1, d)))],
          [binary "~" (Bin LogBase) AssocLeft],
	  [binary "*" (Bin Mul) AssocLeft, binary "/" (Bin Div) AssocLeft],
          [binary "+" (Bin Add) AssocLeft, binary "-" (Bin Sub) AssocLeft]
         ]
     

mulMerge :: Expr -> Expr -> Expr
mulMerge (Evaled (ra, da)) (Evaled (rb, db)) = Evaled (ra*rb, f da db) where 
	f a b = Dims $ Map.unionWith (+) (Map.filter (/=0) $ unDims a) (Map.filter (/=0) $ unDims b)
mulMerge e1 e2 = Bin Mul e1 e2

parseArgRef, factor, call :: MyParser Expr

factor = brackets parseExpr <|> number <|> try parseArgRef <|> call

call = (do
        (n, e) <- parseExistingName
        args <- option [] (brackets (parseExpr `sepBy` parseComma))
	case e of
		(Function _ _) -> test n args
		(Builtin _ _) -> test n args
		_ -> fail $ pretty n ++ " is not a function"
	) <?> "function application"
	where
		test :: Name -> [Expr] -> MyParser Expr
		test n args = do
			state <- getState
			case (runState $ runErrorT (do
					args' <- mapM eval args
					doCall n args')) state of
				(Left e, _) -> fail e
				(Right _, _) -> return (Call n args) -- doCall should not change the state


parseArgRef = (do
        n' <- parseName
	let n = unName n'
	state <- getState
	case constrArgRef 0 n (getArgs state) of
		Left s -> fail s
		Right e -> return e
	) <?> "argument reference"

	where
		constrArgRef :: Int -> String -> Args -> Either String Expr
		constrArgRef _ s [] = Left $ "no such argument in definition list: " ++ pretty s
		constrArgRef i s (a:as)
			| getArgName a == s = Right $ ArgRef (Arg s i (getArgType a))
			| otherwise = constrArgRef (i+1) s as


parseEinh :: MyParser Dims
parseEinh = do
	res <- many1 eh0
	state <- getState
	case (runState $ runErrorT (mergeDims res)) state of
		(Left e, _) -> fail e
		(Right dims, _) -> return dims -- mergeDims is not supposed to change the state

mergeDims :: [(Mon Dims -> Mon Dims)] -> Mon Dims
mergeDims [] = return noDims
mergeDims [a] = a (return noDims)
mergeDims (a:as) = a (mergeDims as)

eh0 :: MyParser (Mon Dims -> Mon Dims)
eh0 = try (do
	op <- option (#*#) (do
		spaces
		char '/'
		return (#/#))
	spaces
	r <- eh1
	return ((flip op) (return r)))


eh1 :: MyParser Dims
eh1  = 	try (do spaces; char '('; spaces; r <- parseEinh ; spaces; char ')'; return r;) <|> (do
        n <- eh2
        option (Dims $ Map.singleton n 1) (do
		spaces
                char '^'
		spaces
                i <- fractOrInt
		spaces
                return $ Dims $ Map.singleton n i))

eh2 :: MyParser Name
eh2  = try (do
      	(name, entry) <- parseExistingName
	case entry of
		BasicDimension -> return name
		Dimension _ -> return name
		_ -> fail (pretty name ++ " is not a unit")
	) <?> "unit name"

parseName :: MyParser Name
parseName = do
        r1 <- letter
        r2 <- many (oneOf "_'" <|> digit <|> letter)
        spaces
        return $ Name (r1:r2)


parseExistingName :: MyParser (Name, StateEntry)
parseExistingName = do
        n <- parseName
	e <- requireEntry n
	return $! (n, e)

int :: MyParser Integer
int = do
	o <- option ' ' $ char '-'
	spaces
	n <- many1 digit
	spaces
	return $ ((read $ o:n)::Integer)

number :: MyParser Expr
number = do
	n <- (try fract) <|> real
	spaces
	return $ Evaled (n, noDims)



fractOrInt :: MyParser R
fractOrInt = (try fract) <|> intF

intF :: MyParser R
intF = do
	spaces
	r <- int
	spaces
	return (r % 1)

fract :: MyParser R
fract = do
	spaces
	r1 <- many1 digit
	spaces
	char '%'
	spaces
	r2 <- many1 digit
	spaces
	return $ ((read r1)::Integer)%((read r2)::Integer)

real :: MyParser R
real  = do
	r1 <- many1 digit
	res <- option (fromInteger ((read r1)::Integer)) (do
		char '.'
		r2 <- many1 digit
		spaces
		let
			rr1 = ((read r1)::Integer)
			rr2 = ((read r2)::Integer) -- FIXME it may be more efficient to textually append length r2 zeros here.
			l = 10^length r2
		return $ (rr1 * l + rr2) % l)

	res' <- option res (try (do
		spaces
		char 'e'
		spaces
		f <- option id (do {char '-'; return negate})
		spaces
		exp_ <- many1 digit
		spaces
		return (res * (10 ^^ f (read exp_ :: Integer)))))

	return res'
	<?> "real"

parseMinus, parseColon, parseBind, parseBindE, parseLB, parseRB, parseComma :: MyParser String
parseMinus  = addSpace (string "-")
parseColon  = addSpace (string ":")
parseBind   = addSpace (string "=")
parseBindE  = addSpace (string ":=")
parseLB     = addSpace (string "(")
parseRB     = addSpace (string ")")
parseComma  = addSpace (string ",")

brackets,  addSpace :: MyParser a -> MyParser a
brackets p = try (do
        parseLB
        r <- p
        parseRB
        return r)

addSpace a = do
	r <- a
	spaces
	return r