diff --git a/app/Main.hs b/app/Main.hs index 02988c7d..a24714a2 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -158,6 +158,7 @@ startingGlobalEnv noArray = , addCommand "macro-log" (CommandFunction commandPrint) , addCommand "expand" (CommandFunction commandExpand) , addCommand "use" (CommandFunction commandUse) + , addCommand "type" (CommandFunction commandType) ] ++ (if noArray then [] else [("Array", Binder (XObj (Mod arrayModule) Nothing Nothing))]) startingTypeEnv :: Env diff --git a/docs/Todo.md b/docs/Todo.md index e27daa5b..9fac5c42 100644 --- a/docs/Todo.md +++ b/docs/Todo.md @@ -9,6 +9,7 @@ * [0.3] Can't define globals with heap allocated types (String, structs, etc.) * [0.3] The compiler can crash when defining invalid struct types, it should present nice errors instead * [0.3] When loading game.carp the SDL modules fail because of invalid paths, the CARP_DIR + path isn't searched it seems +* [0.3] Can run (type NONEXISTINGNAMESPACE.println) ## Big Language Features * [0.3] Allow evaluation of dynamic functions in the REPL and give access to the Commands from dynamic code diff --git a/src/Commands.hs b/src/Commands.hs index 5ce5518c..27c0aa69 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -35,7 +35,6 @@ data ReplCommand = Define XObj | DefineDynamic String XObj XObj | DefineAlias String XObj | DefineInterface String XObj (Maybe Info) - | Type XObj | GetInfo XObj | InstantiateTemplate XObj XObj | ProjectSet String String @@ -89,7 +88,6 @@ objToCommand ctx xobj = [XObj (Sym (SymPath _ "definterface")) _ _, XObj (Sym (SymPath _ name)) _ _, t] ->return $ DefineInterface name t (info xobj) [XObj (Sym (SymPath _ "eval")) _ _, form] ->return $ Eval form [XObj (Sym (SymPath _ "instantiate")) _ _, name, signature] ->return $ InstantiateTemplate name signature - [XObj (Sym (SymPath _ "type")) _ _, form] ->return $ Type form [XObj (Sym (SymPath _ "info")) _ _, form] ->return $ GetInfo form [XObj (Sym (SymPath _ "project-set!")) _ _, XObj (Sym (SymPath _ key)) _ _, XObj (Str value) _ _] -> return $ ProjectSet key value @@ -274,25 +272,6 @@ executeCommand ctx@(Context env typeEnv pathStrings proj lastInput execMode) cmd do putStrLnWithColor Red ("Can't get info from non-symbol: " ++ pretty xobj) return ctx - Type xobj -> - case xobj of - XObj (Sym path@(SymPath _ name)) _ _ -> - case lookupInEnv path env of - Just (_, binder) -> - do putStrLnWithColor White (show binder) - return ctx - Nothing -> - case multiLookupALL name env of - [] -> - do putStrLnWithColor Red ("Can't find '" ++ show path ++ "'") - return ctx - binders -> - do mapM_ (\(env, binder) -> putStrLnWithColor White (show binder)) binders - return ctx - _ -> - do putStrLnWithColor Red ("Can't get the type of non-symbol: " ++ pretty xobj) - return ctx - Register name xobj -> case xobjToTy xobj of Just t -> let path = SymPath pathStrings name @@ -733,7 +712,7 @@ commandExpand [xobj] = liftIO $ do putStrLnWithColor Yellow (pretty expanded) return dynamicNil commandExpand args = - liftIO $ do putStrLnWithColor Red ("Invalid args to 'commandExpand':" ++ joinWithComma (map pretty args)) + liftIO $ do putStrLnWithColor Red ("Invalid args to 'expand':" ++ joinWithComma (map pretty args)) return dynamicNil commandUse :: CommandCallback @@ -752,3 +731,28 @@ commandUse [xobj@(XObj (Sym path) _ _)] = Nothing -> liftIO $ do putStrLnWithColor Red ("Can't find a module named '" ++ show path ++ "' at " ++ prettyInfoFromXObj xobj ++ ".") return dynamicNil + +commandType :: CommandCallback +commandType [xobj] = + do ctx <- get + let env = contextGlobalEnv ctx + case xobj of + XObj (Sym path@(SymPath _ name)) _ _ -> + case lookupInEnv path env of + Just (_, binder) -> + liftIO $ do putStrLnWithColor White (show binder) + return dynamicNil + Nothing -> + case multiLookupALL name env of + [] -> + liftIO $ do putStrLnWithColor Red ("Can't find '" ++ show path ++ "'") + return dynamicNil + binders -> + liftIO $ do mapM_ (\(env, binder) -> putStrLnWithColor White (show binder)) binders + return dynamicNil + _ -> + liftIO $ do putStrLnWithColor Red ("Can't get the type of non-symbol: " ++ pretty xobj) + return dynamicNil +commandType args = + liftIO $ do putStrLnWithColor Red ("Invalid args to 'type':" ++ joinWithComma (map pretty args)) + return dynamicNil