module Language.Egison.Util (getEgisonExpr, getEgisonExprOrNewLine, completeEgison) where
import Control.Monad.Except (liftIO)
import Data.List
import System.Console.Haskeline hiding (catch, handle, throwTo)
import Text.Regex.TDFA
import Language.Egison.Parser as Parser
import Language.Egison.ParserNonS as ParserNonS
import Language.Egison.Types
getEgisonExpr :: Bool -> String -> InputT IO (Maybe (String, EgisonTopExpr))
getEgisonExpr isSExpr prompt = getEgisonExpr' isSExpr prompt ""
getEgisonExpr' :: Bool -> String -> String -> InputT IO (Maybe (String, EgisonTopExpr))
getEgisonExpr' isSExpr prompt prev = do
mLine <- case prev of
"" -> getInputLine prompt
_ -> getInputLine $ replicate (length prompt) ' '
case mLine of
Nothing -> return Nothing
Just [] ->
if null prev
then getEgisonExpr isSExpr prompt
else getEgisonExpr' isSExpr prompt prev
Just line -> do
let input = prev ++ line
case (if isSExpr then Parser.parseTopExpr else ParserNonS.parseTopExpr) input of
Left err | show err =~ "unexpected end of input" ->
getEgisonExpr' isSExpr prompt $ input ++ "\n"
Left err -> do
liftIO $ print err
getEgisonExpr isSExpr prompt
Right topExpr -> return $ Just (input, topExpr)
getEgisonExprOrNewLine :: Bool -> String -> InputT IO (Either (Maybe String) (String, EgisonTopExpr))
getEgisonExprOrNewLine isSExpr prompt = getEgisonExprOrNewLine' isSExpr prompt ""
getEgisonExprOrNewLine' :: Bool -> String -> String -> InputT IO (Either (Maybe String) (String, EgisonTopExpr))
getEgisonExprOrNewLine' isSExpr prompt prev = do
mLine <- case prev of
"" -> getInputLine prompt
_ -> getInputLine $ replicate (length prompt) ' '
case mLine of
Nothing -> return $ Left Nothing
Just [] -> return $ Left $ Just ""
Just line -> do
let input = prev ++ line
case (if isSExpr then Parser.parseTopExpr else ParserNonS.parseTopExpr) input of
Left err | show err =~ "unexpected end of input" ->
getEgisonExprOrNewLine' isSExpr prompt $ input ++ "\n"
Left err -> do
liftIO $ print err
getEgisonExprOrNewLine isSExpr prompt
Right topExpr -> return $ Right (input, topExpr)
completeEgison :: Monad m => CompletionFunc m
completeEgison arg@(')':_, _) = completeParen arg
completeEgison arg@('>':_, _) = completeParen arg
completeEgison arg@(']':_, _) = completeParen arg
completeEgison arg@('}':_, _) = completeParen arg
completeEgison arg@('(':_, _) = completeWord Nothing " \t<>[]{}$," completeAfterOpenParen arg
completeEgison arg@('<':_, _) = completeWord Nothing " \t()[]{}$," completeAfterOpenCons arg
completeEgison arg@(' ':_, _) = completeWord Nothing "" completeNothing arg
completeEgison arg@('[':_, _) = completeWord Nothing "" completeNothing arg
completeEgison arg@('{':_, _) = completeWord Nothing "" completeNothing arg
completeEgison arg@([], _) = completeWord Nothing "" completeNothing arg
completeEgison arg@(_, _) = completeWord Nothing " \t[]{}$," completeEgisonKeyword arg
completeAfterOpenParen :: Monad m => String -> m [Completion]
completeAfterOpenParen str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) $ egisonPrimitivesAfterOpenParen ++ egisonKeywordsAfterOpenParen
completeAfterOpenCons :: Monad m => String -> m [Completion]
completeAfterOpenCons str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywordsAfterOpenCons
completeNothing :: Monad m => String -> m [Completion]
completeNothing _ = return []
completeEgisonKeyword :: Monad m => String -> m [Completion]
completeEgisonKeyword str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywords
egisonPrimitivesAfterOpenParen = map ((:) '(') ["+", "-", "*", "/", "numerator", "denominator", "modulo", "quotient", "remainder", "neg", "abs", "eq?", "lt?", "lte?", "gt?", "gte?", "round", "floor", "ceiling", "truncate", "sqrt", "exp", "log", "sin", "cos", "tan", "asin", "acos", "atan", "sinh", "cosh", "tanh", "asinh", "acosh", "atanh", "itof", "rtof", "stoi", "read", "show", "empty?", "uncons", "unsnoc", "assert", "assert-equal"]
egisonKeywordsAfterOpenParen = map ((:) '(') ["define", "let", "letrec", "lambda", "match", "match-all", "match-lambda", "matcher", "algebraic-data-matcher", "pattern-function", "if", "loop", "io", "do"]
++ ["id", "or", "and", "not", "char", "eq?/m", "compose", "compose3", "list", "map", "between", "repeat1", "repeat", "filter", "separate", "concat", "foldr", "foldl", "map2", "zip", "member?", "member?/m", "include?", "include?/m", "any", "all", "length", "count", "count/m", "car", "cdr", "rac", "rdc", "nth", "take", "drop", "while", "reverse", "multiset", "add", "add/m", "delete-first", "delete-first/m", "delete", "delete/m", "difference", "difference/m", "union", "union/m", "intersect", "intersect/m", "set", "unique", "unique/m", "print", "print-to-port", "each", "pure-rand", "fib", "fact", "divisor?", "gcd", "primes", "find-factor", "prime-factorization", "p-f", "min", "max", "min-and-max", "power", "mod", "sort", "intersperse", "intercalate", "split", "split/m"]
egisonKeywordsAfterOpenCons = map ((:) '<') ["nil", "cons", "join", "snoc", "nioj"]
egisonKeywordsInNeutral = "something" : ["bool", "string", "integer", "nats", "primes"]
egisonKeywords = egisonPrimitivesAfterOpenParen ++ egisonKeywordsAfterOpenParen ++ egisonKeywordsAfterOpenCons ++ egisonKeywordsInNeutral
completeParen :: Monad m => CompletionFunc m
completeParen (lstr, _) = case closeParen lstr of
Nothing -> return (lstr, [])
Just paren -> return (lstr, [Completion paren paren False])
closeParen :: String -> Maybe String
closeParen str = closeParen' 0 $ removeCharAndStringLiteral str
removeCharAndStringLiteral :: String -> String
removeCharAndStringLiteral [] = []
removeCharAndStringLiteral ('"':'\\':str) = '"':'\\':removeCharAndStringLiteral str
removeCharAndStringLiteral ('"':str) = removeCharAndStringLiteral' str
removeCharAndStringLiteral ('\'':'\\':str) = '\'':'\\':removeCharAndStringLiteral str
removeCharAndStringLiteral ('\'':str) = removeCharAndStringLiteral' str
removeCharAndStringLiteral (c:str) = c:removeCharAndStringLiteral str
removeCharAndStringLiteral' :: String -> String
removeCharAndStringLiteral' [] = []
removeCharAndStringLiteral' ('"':'\\':str) = removeCharAndStringLiteral' str
removeCharAndStringLiteral' ('"':str) = removeCharAndStringLiteral str
removeCharAndStringLiteral' ('\'':'\\':str) = removeCharAndStringLiteral' str
removeCharAndStringLiteral' ('\'':str) = removeCharAndStringLiteral str
removeCharAndStringLiteral' (_:str) = removeCharAndStringLiteral' str
closeParen' :: Integer -> String -> Maybe String
closeParen' _ [] = Nothing
closeParen' 0 ('(':_) = Just ")"
closeParen' 0 ('<':_) = Just ">"
closeParen' 0 ('[':_) = Just "]"
closeParen' 0 ('{':_) = Just "}"
closeParen' n ('(':str) = closeParen' (n - 1) str
closeParen' n ('<':str) = closeParen' (n - 1) str
closeParen' n ('[':str) = closeParen' (n - 1) str
closeParen' n ('{':str) = closeParen' (n - 1) str
closeParen' n (')':str) = closeParen' (n + 1) str
closeParen' n ('>':str) = closeParen' (n + 1) str
closeParen' n (']':str) = closeParen' (n + 1) str
closeParen' n ('}':str) = closeParen' (n + 1) str
closeParen' n (_:str) = closeParen' n str