Misc.hs

module Language.CalDims.Misc (parseLine) where

import Text.ParserCombinators.Parsec
import qualified Data.List as List
import Control.Monad

import Language.CalDims.Expression
import Language.CalDims.Expr ()
import Language.CalDims.Action
import Language.CalDims.Types


eof' :: MyParser ()
eof' = do
	spaces
	eof

parseConversion :: MyParser Conversion
parseConversion = do
	spaces
	char '|'
	spaces
	c <- try (pr parseEinh Explicit) <|> try (pr parseExpr InTermsOf) <|>
		(char '-' >> return Basic) <|>
		(char '*' >> return Keep) <|>
		(char '?' >> return Minimal)
	spaces
	return c
	where pr f rc = f >>= return . rc

parseFilename :: MyParser String
parseFilename = many1 (oneOf (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['_', '.', '-']))

parseShort :: String -> MyParser String
parseShort s = do
	res <- string $ "\\" ++ s
	(char ' ' >> return ()) <|> eof
	spaces
	return res

parseGetState, parseWriteState, parseDebugName, parseDebugExpr, parseDebugDependencies, parseEval,  parseHelp, parseRemove, parseRemoveCascade, parseEcho, parseAddUnit, parseAddBasicUnit, parseAddFunction :: MyParser Command

parseComment, parseEmpty :: MyParser ()

parseGetState = do
	parseShort "s"
	eof'
	return GetState

parseWriteState = do
	parseShort "s"
	name <- parseFilename
	eof'
	return $ WriteState name

parseDebugExpr = do
	try (parseShort "de") <|> parseShort "d"
	e <- parseExpr
	eof'
	return $ DebugExpr e

parseDebugName = do
	parseShort "dn"
	n <- parseName
	eof'
	return $ DebugName n

parseDebugDependencies = do
	parseShort "dp"
	n <- parseName
	eof'
	return $ DebugDependencies n	

parseEval = do
	e <- parseExpr
	conversion <- option Keep parseConversion
	eof'
	return $ Eval e conversion

parseComment = do
	spaces
	char '#'
	flush
	return ()

parseEmpty = do
	spaces
	eof'
	return ()

parseHelp = do
	parseShort "?"
	eof'
	return Help

parseRemove = do
	parseShort "r"
	name <- parseName
	eof'
	return $ Remove name

parseRemoveCascade = do
	parseShort "rc"
	name <- parseName
	eof'
	return $ RemoveCascade name

parseEcho = do
	parseShort "p"
	s <- many1 anyChar
	eof'
	return $ Echo s

parseAddBasicUnit = do
	parseShort "u"
	name <- parseName
	eof'
	return $ AddBasicUnit name

parseAddUnit = do
	fn <- parseName
	parseBindE
	expr <- parseNonRecursiveExpr fn
	return $ AddUnit fn expr

parseAddFunction = do
	oState <- getState
	fn <- parseName
	args' <- option [] (brackets (sepBy (do
		n <- parseName
		e <- option noDims (do
			parseColon
			parseEinh)
		return $ Arg (unName n) 0 e) parseComma))
	let args = zipWith (\ (Arg s _ d) n -> Arg s n d) args' [0..]
	parseBind
	updateState (\x -> x {getArgs = args, getArgValues = map (\ (Arg _ _ d) -> (undefined, d)) args})
	expr <- parseNonRecursiveExpr fn
	when (getArgRefs expr /= (List.nub . List.sort $ args)) (fail "one/some of the parameters are not used in the expression")
	updateState (\_ -> oState)
	return $ AddFunction fn  args  expr

getArgRefs', getArgRefs :: Expr -> [Arg]

getArgRefs = List.nub . List.sort . getArgRefs'

getArgRefs' (Bin _ e1 e2) = getArgRefs e1 ++ getArgRefs e2
getArgRefs' (Uni _ e) = getArgRefs e
getArgRefs' (ArgRef r) = [r]
getArgRefs' (Call _ es) = foldl (++) [] (map getArgRefs es)
getArgRefs' (Evaled _) = []

parseLine :: MyParser (Maybe Command)
parseLine  = do

	let all_ =
		map try 
		[ parseGetState
		, parseWriteState
		, parseDebugName
		, parseDebugExpr
		, parseDebugDependencies
		, parseHelp
		, parseRemove
		, parseRemoveCascade
		, parseEcho
		, parseAddBasicUnit
		, parseEval
		, parseAddUnit
		, parseAddFunction

		]
	spaces
	command <- (do parseComment <|> parseEmpty; return Nothing) <|> (do res <- foldl1 (<|>) all_; return $ Just res)
	eof'
	return command