diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Builtins.hs | 87 | ||||
| -rw-r--r-- | src/Evaluator.hs | 47 | ||||
| -rw-r--r-- | src/Parser.hs | 19 | ||||
| -rw-r--r-- | src/Tokenizer.hs | 5 | ||||
| -rw-r--r-- | src/Utils.hs | 31 |
5 files changed, 107 insertions, 82 deletions
diff --git a/src/Builtins.hs b/src/Builtins.hs index f8d1567..ebaad42 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -37,13 +37,16 @@ builtinEnv = M.fromList [ ] argError1 :: String -> AST -> String -argError1 fn arg = pos arg ++ ": invalid argument to " ++ fn ++ ": " ++ show arg +argError1 fn arg1 = + "invalid argument to " ++ fn ++ ": " ++ show arg1 -argError2 :: (Show a1, Show a2) => String -> a1 -> a2 -> String -argError2 fn arg1 arg2 = "invalid arguments to " ++ fn ++ ": " ++ show arg1 ++ ", " ++ show arg2 +argError2 :: String -> AST -> AST -> String +argError2 fn arg1 arg2 = + "invalid arguments to " ++ fn ++ ": " ++ show arg1 ++ ", " ++ show arg2 -argError3 :: (Show a1, Show a2, Show a3) => String -> a1 -> a2 -> a3 -> String -argError3 fn arg1 arg2 arg3 = "invalid arguments to " ++ fn ++ ": " ++ show arg1 ++ ", " ++ show arg2 ++ ", " ++ show arg3 +argError3 :: String -> AST -> AST -> AST -> String +argError3 fn arg1 arg2 arg3 = + "invalid arguments to " ++ fn ++ ": " ++ show arg1 ++ ", " ++ show arg2 ++ ", " ++ show arg3 -- BUILTINS @@ -54,13 +57,13 @@ builtinAdd2 = (name, makeNonsenseAST $ ASTFunction fn1) where return $ makeNonsenseAST $ ASTFunction $ fn2 where fn2 _ AST { astNode = ASTInteger b } = return $ makeNonsenseAST $ ASTInteger $ a + b - fn2 _ ast2 = throwL $ argError2 name ast1 ast2 + fn2 _ ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 _ ast1@AST { astNode = ASTDouble a } = return $ makeNonsenseAST $ ASTFunction $ fn2 where fn2 _ AST { astNode = ASTDouble b } = return $ makeNonsenseAST $ ASTDouble $ a + b - fn2 _ ast2 = throwL $ argError2 name ast1 ast2 - fn1 _ ast1 = throwL $ argError1 name ast1 + fn2 _ ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 + fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinSubtract2 :: (String, AST) builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction fn1) where @@ -69,13 +72,13 @@ builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction fn1) where return $ makeNonsenseAST $ ASTFunction $ fn2 where fn2 _ AST { astNode = ASTInteger b } = return $ makeNonsenseAST $ ASTInteger $ a - b - fn2 _ ast2 = throwL $ argError2 name ast1 ast2 + fn2 _ ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 _ ast1@AST { astNode = ASTDouble a } = return $ makeNonsenseAST $ ASTFunction $ fn2 where fn2 _ AST { astNode = ASTDouble b } = return $ makeNonsenseAST $ ASTDouble $ a - b - fn2 _ ast2 = throwL $ argError2 name ast1 ast2 - fn1 _ ast1 = throwL $ argError1 name ast1 + fn2 _ ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 + fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinMultiply2 :: (String, AST) builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction fn1) where @@ -84,30 +87,30 @@ builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction fn1) where return $ makeNonsenseAST $ ASTFunction $ fn2 where fn2 _ AST { astNode = ASTInteger b } = return $ makeNonsenseAST $ ASTInteger $ a * b - fn2 _ ast2 = throwL $ argError2 name ast1 ast2 + fn2 _ ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 _ ast1@AST { astNode = ASTDouble a } = return $ makeNonsenseAST $ ASTFunction $ fn2 where fn2 _ AST { astNode = ASTDouble b } = return $ makeNonsenseAST $ ASTDouble $ a * b - fn2 _ ast2 = throwL $ argError2 name ast1 ast2 - fn1 _ ast1 = throwL $ argError1 name ast1 + fn2 _ ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 + fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinDivide2 :: (String, AST) builtinDivide2 = (name, makeNonsenseAST $ ASTFunction fn1) where name = "/" fn1 _ ast1@AST { astNode = ASTInteger a } = return $ makeNonsenseAST $ ASTFunction $ fn2 where - fn2 _ AST { astNode = ASTInteger b } = - do when (b == 0) $ throwL $ "division by zero" + fn2 _ ast2@AST { astNode = ASTInteger b } = + do when (b == 0) $ throwL (astPos ast2) $ "division by zero" return $ makeNonsenseAST $ ASTInteger $ a `div` b - fn2 _ ast2 = throwL $ argError2 name ast1 ast2 + fn2 _ ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 _ ast1@AST { astNode = ASTDouble a } = return $ makeNonsenseAST $ ASTFunction $ fn2 where - fn2 _ AST { astNode = ASTDouble b } = - do when (b == 0) $ throwL $ "division by zero" + fn2 _ ast2@AST { astNode = ASTDouble b } = + do when (b == 0) $ throwL (astPos ast2) $ "division by zero" return $ makeNonsenseAST $ ASTDouble $ a / b - fn2 _ ast2 = throwL $ argError2 name ast1 ast2 - fn1 _ ast1 = throwL $ argError1 name ast1 + fn2 _ ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 + fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinEq2 :: (String, AST) builtinEq2 = (name, makeNonsenseAST $ ASTFunction fn1) where @@ -127,13 +130,13 @@ builtinFloor :: (String, AST) builtinFloor = (name, makeNonsenseAST $ ASTFunction fn1) where name = "floor" fn1 _ AST { astNode = ASTDouble dbl } = return $ makeNonsenseAST $ ASTInteger $ floor dbl - fn1 _ ast = throwL $ argError1 name ast + fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinToDouble :: (String, AST) builtinToDouble = (name, makeNonsenseAST $ ASTFunction fn1) where name = "to-double" fn1 _ AST { astNode = ASTInteger int } = return $ makeNonsenseAST $ ASTDouble $ fromIntegral int - fn1 _ ast = throwL $ argError1 name ast + fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinFmt :: (String, AST) builtinFmt = (name, makeNonsenseAST $ ASTFunction fn1) where @@ -143,8 +146,8 @@ builtinFmt = (name, makeNonsenseAST $ ASTFunction fn1) where fn2 _ AST { astNode = ASTVector replacements } = return $ makeNonsenseAST $ ASTString $ T.unpack $ replaceAll (0 :: Int) replacements (T.pack str) - fn2 _ ast2 = throwL $ argError2 name ast1 ast2 - fn1 _ ast1 = throwL $ argError1 name ast1 + fn2 _ ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 + fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1 replaceAll _ [] text = text replaceAll n (x:xs) text = let text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ show x) text @@ -153,18 +156,18 @@ builtinFmt = (name, makeNonsenseAST $ ASTFunction fn1) where builtinHead :: (String, AST) builtinHead = (name, makeNonsenseAST $ ASTFunction fn1) where name = "head" - fn1 _ AST { astNode = ASTVector vec } = - do when (length vec == 0) $ throwL $ name ++ " of empty vector" + fn1 _ ast1@AST { astNode = ASTVector vec } = + do when (length vec == 0) $ throwL (astPos ast1) $ name ++ " of empty vector" return $ head vec - fn1 _ ast = throwL $ argError1 name ast + fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinTail :: (String, AST) builtinTail = (name, makeNonsenseAST $ ASTFunction fn1) where name = "tail" - fn1 _ AST { astNode = ASTVector vec } = - do when (length vec == 0) $ throwL $ name ++ " of empty vector" + fn1 _ ast1@AST { astNode = ASTVector vec } = + do when (length vec == 0) $ throwL (astPos ast1) $ name ++ " of empty vector" return $ makeNonsenseAST $ ASTVector $ tail vec - fn1 _ ast = throwL $ argError1 name ast + fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinSubstr :: (String, AST) builtinSubstr = (name, makeNonsenseAST $ ASTFunction fn1) where @@ -175,9 +178,9 @@ builtinSubstr = (name, makeNonsenseAST $ ASTFunction fn1) where return $ makeNonsenseAST $ ASTFunction $ fn3 where fn3 _ AST { astNode = ASTString str } = return $ makeNonsenseAST $ ASTString $ drop at .> take len $ str - fn3 _ ast3 = throwL $ argError3 name ast1 ast2 ast3 - fn2 _ ast2 = throwL $ argError2 name ast1 ast2 - fn1 _ ast1 = throwL $ argError1 name ast1 + fn3 _ ast3 = throwL (astPos ast3) $ argError3 name ast1 ast2 ast3 + fn2 _ ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 + fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinPrepend :: (String, AST) builtinPrepend = (name, makeNonsenseAST $ ASTFunction fn1) where @@ -186,7 +189,7 @@ builtinPrepend = (name, makeNonsenseAST $ ASTFunction fn1) where return $ makeNonsenseAST $ ASTFunction $ fn2 where fn2 _ AST { astNode = ASTVector vec } = return $ makeNonsenseAST $ ASTVector $ ast1 : vec - fn2 _ ast2 = throwL $ argError2 name ast1 ast2 + fn2 _ ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 builtinPrint :: (String, AST) builtinPrint = (name, makeNonsenseAST $ ASTFunction fn1) where @@ -194,7 +197,7 @@ builtinPrint = (name, makeNonsenseAST $ ASTFunction fn1) where fn1 _ AST { astNode = ASTString str } = do liftIO $ putStr $ str return $ makeNonsenseAST ASTUnit - fn1 _ ast = throwL $ argError1 name ast + fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinConcat :: (String, AST) builtinConcat = (name, makeNonsenseAST $ ASTFunction fn1) where @@ -203,13 +206,13 @@ builtinConcat = (name, makeNonsenseAST $ ASTFunction fn1) where return $ makeNonsenseAST $ ASTFunction $ fn2 where fn2 _ AST { astNode = ASTString str2 } = return $ makeNonsenseAST $ ASTString $ str1 ++ str2 - fn2 _ ast2 = throwL $ argError2 name ast1 ast2 - fn1 _ ast1 = throwL $ argError1 name ast1 + fn2 _ ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 + fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinFatal :: (String, AST) builtinFatal = (name, makeNonsenseAST $ ASTFunction fn1) where name = "fatal" - fn1 _ AST { astNode = ASTString str } = - throwL $ str - fn1 _ ast = - throwL $ argError1 name ast + fn1 _ ast1@AST { astNode = ASTString str } = + throwL (astPos ast1) $ str + fn1 _ ast1 = + throwL (astPos ast1) $ argError1 name ast1 diff --git a/src/Evaluator.hs b/src/Evaluator.hs index 754c0b1..4f40706 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -18,7 +18,7 @@ _curryCall env (arg:rest) f = do g <- _curryCall env rest f case astNode g of ASTFunction f' -> f' env arg - other -> throwL $ "cannot call value " ++ show other ++ " as a function" + other -> throwL (astPos g) $ "cannot call value " ++ show other ++ " as a function" curryCall :: Env -> [AST] -> LFunction -> LContext AST curryCall env [] f = f env (makeNonsenseAST ASTUnit) @@ -55,7 +55,7 @@ letArgsToSymValPairs env args = return (symbol', evaledValue) [AST { astNode = ASTSymbol "lazy" }, AST { astNode = ASTSymbol symbol' }, value'] -> do return (symbol', value') - other -> throwL $ "let called with invalid args " ++ show other + other -> throwL (astPos $ head other) $ "let called with invalid args " ++ show other defineUserFunction :: AST -> [AST] -> LContext LFunction defineUserFunction AST { astNode = ASTSymbol param } exprs = return fn where @@ -65,7 +65,7 @@ defineUserFunction AST { astNode = ASTSymbol param } exprs = return fn where let letExprs = take (length exprs - 1) replacedExprs letSymValPairs <- letExprs $> mapM (\case AST { astNode = ASTFunctionCall v } -> return $ drop 1 v - _ -> throwL $ "unreachable: map letExprs") + ast -> throwL (astPos ast) $ "unreachable: map letExprs, ast: " ++ show ast) .> fmap (mapM $ letArgsToSymValPairs env) .> join let body = head $ drop (length exprs - 1) replacedExprs let newBody = traverseAndReplace param arg body @@ -73,7 +73,8 @@ defineUserFunction AST { astNode = ASTSymbol param } exprs = return fn where (_, ret) <- evaluate env newBody return ret -defineUserFunction param exprs = throwL $ "unreachable: defineUserFunction, param: " ++ show param ++ ", exprs: " ++ show exprs +defineUserFunction param exprs = throwL (astPos param) + $ "unreachable: defineUserFunction, param: " ++ show param ++ ", exprs: " ++ show exprs defineUserFunctionWithLetExprs :: [AST] -> [AST] -> LContext LFunction defineUserFunctionWithLetExprs [] exprs = @@ -89,7 +90,8 @@ defineUserFunctionWithLetExprs (AST { astNode = ASTSymbol param }:rest) exprs = -- the returned AST will not have the correct position info, but that's fine -- because the info is overridden in evaluateFunctionDef anyway return $ makeNonsenseAST $ ASTFunction $ ret -defineUserFunctionWithLetExprs _ _ = throwL $ "unreachable: defineUserFunctionWithLetExprs" +defineUserFunctionWithLetExprs (param:_) _ = throwL (astPos $ param) + $ "unreachable: defineUserFunctionWithLetExprs, param: " ++ show param evaluateFunctionDef :: Env -> [AST] -> LContext (Env, AST) evaluateFunctionDef env asts = do @@ -98,29 +100,35 @@ evaluateFunctionDef env asts = do (params'', exprs) <- case args of args' | length args' < 2 -> - throwL $ "\\ called with " ++ show (length args) ++ " arguments" + throwL (astPos defAst) $ "\\ called with " ++ show (length args) ++ " arguments" | otherwise -> return $ (head args', tail args') AST { astNode = ASTVector params' } <- assertIsASTVector params'' params <- mapM assertIsASTSymbol params' let letExprs = take (length exprs - 1) exprs - unless (all (\case ASTFunctionCall (AST { astNode = ASTSymbol "let" }:_) -> True; _ -> False) (map astNode letExprs)) - $ throwL "non-let expression in function definition before body" + let nonLetExprM = L.find isLetAST letExprs + case nonLetExprM of + Just nonLetExpr -> throwL (astPos nonLetExpr) + $ "non-let expression in function definition before body: " ++ show nonLetExpr + Nothing -> return () fn <- defineUserFunctionWithLetExprs params exprs return $ (env, defAst { astNode = ASTFunction fn }) + where + isLetAST AST { astNode = ASTFunctionCall (AST { astNode = ASTSymbol "let" }:_) } = True + isLetAST _ = False evaluateMatch :: Env -> [AST] -> LContext (Env, AST) evaluateMatch env asts = do let matchAst = head asts args = tail asts (actualExpr, rest) <- case args of - [] -> throwL $ "match called with no arguments" - (_:[]) -> throwL $ "empty match cases" + [] -> throwL (astPos matchAst) $ "match called with no arguments" + (_:[]) -> throwL (astPos matchAst) "empty match cases" (a:b) -> return (a, b) pairs <- (asPairsM rest) `catchError` - (\_ -> throwL $ "invalid number of arguments passed to match\n" + (\_ -> throwL (astPos matchAst) $ "invalid number of arguments passed to match\n" ++ "- matching on expr: " ++ show actualExpr ++ "\n" ++ "- arguments: " ++ show rest) @@ -129,7 +137,7 @@ evaluateMatch env asts = do return (env, matchAst { astNode = astNode ret }) where matchPairs :: (AST, AST) -> [(AST, AST)] -> LContext AST - matchPairs (actualExpr, evaledActual) [] = throwL $ "matching case not found when matching on expression: " ++ show actualExpr + matchPairs (actualExpr, evaledActual) [] = throwL (astPos actualExpr) $ "matching case not found when matching on expression: " ++ show actualExpr ++ " (actual value: " ++ show evaledActual ++ ")" matchPairs (actualExpr, evaledActual) ((matcher, branch):restPairs) = do (_, evaledMatcher) <- evaluate env matcher @@ -144,7 +152,7 @@ evaluateLet env asts = do let letAst = head asts args = tail asts (symbol, value) <- letArgsToSymValPairs env args - when (M.member symbol env) $ throwL $ "symbol already defined: " ++ symbol + when (M.member symbol env) $ throwL (astPos letAst) $ "symbol already defined: " ++ symbol let newEnv = M.insert symbol value env return $ (newEnv, letAst { astNode = ASTUnit }) @@ -172,12 +180,13 @@ evaluateUserFunction env children = do -- maybe remove double eval here? can't remember why it was added return (env, fnAst { astNode = astNode result }) -evaluateSymbol :: Env -> String -> LContext (Env, AST) -evaluateSymbol env sym = do +evaluateSymbol :: Env -> AST -> LContext (Env, AST) +evaluateSymbol env ast@AST { astNode = ASTSymbol sym } = do let val = M.lookup sym env case val of - Just ast -> return (env, ast) - Nothing -> throwL $ "symbol " ++ sym ++ " not defined in environment" + Just ast' -> return (env, ast') + Nothing -> throwL (astPos ast) $ "symbol " ++ sym ++ " not defined in environment" +evaluateSymbol _ ast = throwL (astPos ast) $ "unreachable: evaluateSymbol, ast: " ++ show ast evaluate :: Env -> AST -> LContext (Env, AST) evaluate env AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } = @@ -194,8 +203,8 @@ evaluate env AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } = evaluateEnv env args _ -> evaluateUserFunction env args -evaluate env AST { astNode = (ASTSymbol sym) } = - evaluateSymbol env sym +evaluate env ast@AST { astNode = (ASTSymbol _) } = + evaluateSymbol env ast evaluate env ast@AST { astNode = (ASTVector vec) } = do rets <- mapM (evaluate env) vec let vec' = map snd rets diff --git a/src/Parser.hs b/src/Parser.hs index b60fdc9..e46d80c 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -11,15 +11,17 @@ import Utils validateBalance :: [String] -> [AST] -> LContext [AST] validateBalance allowed asts = do - when (ASTSymbol "(" `elem` astNodes && "(" `notElem` allowed) - $ throwL "unbalanced function call" - when (ASTSymbol "[" `elem` astNodes && "[" `notElem` allowed) - $ throwL "unbalanced vector" - when (ASTSymbol "{" `elem` astNodes && "{" `notElem` allowed) - $ throwL "unbalanced hash map" + when (MB.isJust parenM && "(" `notElem` allowed) + $ throwL (astPos $ MB.fromJust parenM) "unbalanced function call" + when (MB.isJust bracketM && "[" `notElem` allowed) + $ throwL (astPos $ MB.fromJust bracketM) "unbalanced vector" + when (MB.isJust curlyM && "{" `notElem` allowed) + $ throwL (astPos $ MB.fromJust curlyM) "unbalanced hash map" return asts where - astNodes = map astNode asts + parenM = L.find ((== ASTSymbol "(") . astNode) asts + bracketM = L.find ((== ASTSymbol "[") . astNode) asts + curlyM = L.find ((== ASTSymbol "{") . astNode) asts parseToken :: Token -> AST parseToken (Token token tr tc tf) @@ -62,8 +64,9 @@ _parse acc (Token { tokenContent = "]" }:rest) = do _parse acc (Token { tokenContent = "}" }:rest) = do let children' = takeWhile (astNode .> (/= ASTSymbol "{")) acc children <- validateBalance ["{"] children' - pairs <- asPairsM $ reverse children let openCurly = MB.fromJust $ L.find (astNode .> (== ASTSymbol "{")) acc + pairs <- asPairsM (reverse children) `catchError` + \(LException _ e) -> throwL (astPos openCurly) e let hmap = openCurly { astNode = ASTHashMap (M.fromList pairs) } let newAcc = hmap : drop (length children + 1) acc _parse newAcc rest diff --git a/src/Tokenizer.hs b/src/Tokenizer.hs index 64ba638..565caa5 100644 --- a/src/Tokenizer.hs +++ b/src/Tokenizer.hs @@ -12,6 +12,9 @@ data TChar = TChar { tColumn :: Int } +posTChar :: String -> TChar -> String +posTChar fileName TChar { tRow = r, tColumn = c } = fileName ++ ":" ++ show r ++ ":" ++ show c + _tokenize :: String -> [Token] -> [TChar] -> [TChar] -> LContext [Token] _tokenize fileName acc current [] = let cur = reverse current @@ -51,7 +54,7 @@ _tokenize fileName acc current (x:xs) tokenColumn = tColumn $ x, tokenFileName = fileName } in do - when (stringLength == -1) $ throwL "unbalanced string literal" + when (stringLength == -1) $ throwL (posTChar fileName x) $ "unbalanced string literal" _tokenize fileName (token : acc) [] stringDropped | tChar x `elem` [' ', '\n', '\t', '\r'] = let cur = reverse current diff --git a/src/Utils.hs b/src/Utils.hs index ba459e8..2a2f607 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -9,7 +9,10 @@ import qualified Data.Char as C -- TYPES -newtype LException = LException String +type PositionString = String +type ErrorString = String +data LException = LException (Maybe PositionString) ErrorString + data Config = Config { configScriptFileName :: Maybe String, configVerboseMode :: Bool, @@ -115,32 +118,32 @@ instance (Ord ASTNode) where assertIsASTFunction :: AST -> LContext AST assertIsASTFunction ast@(AST { astNode = node }) = case node of (ASTFunction _) -> return ast - _ -> throwL $ show node ++ " is not a function" + _ -> throwL (astPos ast) $ show node ++ " is not a function" assertIsASTInteger :: AST -> LContext AST assertIsASTInteger ast@(AST { astNode = node }) = case node of (ASTInteger _) -> return ast - _ -> throwL $ show node ++ " is not an integer" + _ -> throwL (astPos ast) $ show node ++ " is not an integer" assertIsASTSymbol :: AST -> LContext AST assertIsASTSymbol ast@(AST { astNode = node }) = case node of (ASTSymbol _) -> return ast - _ -> throwL $ show node ++ " is not a symbol" + _ -> throwL (astPos ast) $ show node ++ " is not a symbol" assertIsASTVector :: AST -> LContext AST assertIsASTVector ast@(AST { astNode = node }) = case node of (ASTVector _) -> return ast - _ -> throwL $ show node ++ " is not a vector" + _ -> throwL (astPos ast) $ show node ++ " is not a vector" assertIsASTString :: AST -> LContext AST assertIsASTString ast@(AST { astNode = node }) = case node of (ASTString _) -> return ast - _ -> throwL $ show node ++ " is not a string" + _ -> throwL (astPos ast) $ show node ++ " is not a string" assertIsASTFunctionCall :: AST -> LContext AST assertIsASTFunctionCall ast@(AST { astNode = node }) = case node of (ASTFunctionCall _) -> return ast - _ -> throwL $ show node ++ " is not a function call or body" + _ -> throwL (astPos ast) $ show node ++ " is not a function call or body" -- UTILS @@ -159,15 +162,16 @@ evenElems :: [a] -> [a] evenElems [] = [] evenElems (_:xs) = oddElems xs -throwL :: String -> LContext a -throwL s = throwError $ LException s +throwL :: String -> String -> LContext a +throwL p s = throwError $ LException mp s + where mp = if p == "" then Nothing else Just p asPairsM :: [a] -> LContext [(a, a)] asPairsM [] = return [] asPairsM (a:b:rest) = do restPaired <- asPairsM rest return $ (a, b) : restPaired -asPairsM _ = throwL "odd number of elements to pair up" +asPairsM _ = throwL "" "odd number of elements to pair up" asPairs :: [a] -> [(a, a)] asPairs [] = [] @@ -184,5 +188,8 @@ makeNonsenseAST :: ASTNode -> AST makeNonsenseAST node = AST { astNode = node, astRow = -1, astColumn = -1, astFileName = "nonsense"} -pos :: AST -> String -pos AST { astRow = r, astColumn = c, astFileName = f } = f ++ ":" ++ show r ++ ":" ++ show c +astPos :: AST -> String +astPos AST { astRow = r, astColumn = c, astFileName = f } = f ++ ":" ++ show r ++ ":" ++ show c + +tokenPos :: Token -> String +tokenPos Token { tokenRow = r, tokenColumn = c, tokenFileName = f } = f ++ ":" ++ show r ++ ":" ++ show c |