diff --git a/app/Main.hs b/app/Main.hs index 81a3784c..42498763 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -182,4 +182,3 @@ main = do putStrLn "Welcome to Carp 0.2.0" context' <- foldM executeCommand context (map Load args) settings <- readlineSettings runInputT settings (repl context' "") - diff --git a/examples/banana.h b/examples/banana.h new file mode 100644 index 00000000..ec8645cc --- /dev/null +++ b/examples/banana.h @@ -0,0 +1,10 @@ +#ifndef BANANA_H +#define BANANA_H + +// This is an example external struct + +typedef struct { + double price; +} Banana; + +#endif diff --git a/examples/temp.carp b/examples/temp.carp index acd631c6..8d7114c3 100644 --- a/examples/temp.carp +++ b/examples/temp.carp @@ -1,5 +1,5 @@ ;; (use IO) -(use Int) +;;(use Int) ;; (use Float) ;; (use Double) ;; (use Array) @@ -8,8 +8,11 @@ ;; (use Char) ;; (use Bool) -(defn reducer [x y] - (Int.+ @x @y)) +(local-include "../examples/banana.h") -(defn f [xs] - (Array.reduce reducer 0 xs)) +(register-type Apple) +(register-type Banana [price Double]) + +;; (defn main [] +;; (let [b (Banana.init 2.3)] +;; (IO.println &(Double.str (Banana.price &b))))) diff --git a/src/Commands.hs b/src/Commands.hs index ceefe406..914ce386 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -30,7 +30,7 @@ data Context = Context { contextGlobalEnv :: Env data ReplCommand = Define XObj | AddInclude Includer | Register String XObj - | RegisterType String + | RegisterType String [XObj] | AddCFlag String | AddLibraryFlag String | DefineModule String [XObj] (Maybe Info) @@ -111,7 +111,7 @@ objToCommand ctx xobj = XObj (Sym (SymPath _ "use")) _ _ : XObj (Sym path) _ _ : [] -> Use path xobj XObj (Sym (SymPath _ "project-set!")) _ _ : XObj (Sym (SymPath _ key)) _ _ : XObj (Str value) _ _ : [] -> ProjectSet key value XObj (Sym (SymPath _ "register")) _ _ : XObj (Sym (SymPath _ name)) _ _ : t : [] -> Register name t - XObj (Sym (SymPath _ "register-type")) _ _ : XObj (Sym (SymPath _ name)) _ _ : [] -> RegisterType name + XObj (Sym (SymPath _ "register-type")) _ _ : XObj (Sym (SymPath _ name)) _ _ : rest -> RegisterType name rest XObj (Sym (SymPath _ "local-include")) _ _ : XObj (Str file) _ _ : [] -> AddInclude (LocalInclude file) XObj (Sym (SymPath _ "system-include")) _ _ : XObj (Str file) _ _ : [] -> AddInclude (SystemInclude file) XObj (Sym (SymPath _ "add-cflag")) _ _ : XObj (Str flag) _ _ : [] -> AddCFlag flag @@ -283,11 +283,23 @@ executeCommand ctx@(Context env typeEnv pathStrings proj lastInput) cmd = Nothing -> do putStrLnWithColor Red ("Can't understand type when registering '" ++ name ++ "'") return ctx - RegisterType name -> - let path = SymPath pathStrings name - binding = XObj (Lst [XObj ExternalType Nothing Nothing, XObj (Sym path) Nothing Nothing]) Nothing (Just TypeTy) - typeEnv' = TypeEnv (envInsertAt (getTypeEnv typeEnv) path binding) - in return (ctx { contextTypeEnv = typeEnv' }) + RegisterType typeName rest -> + let path = SymPath pathStrings typeName + typeDefinition = XObj (Lst [XObj ExternalType Nothing Nothing, XObj (Sym path) Nothing Nothing]) Nothing (Just TypeTy) + i = Nothing + in case rest of + [] -> + return (ctx { contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) typeName typeDefinition) }) + members -> + case bindingsForRegisteredType typeEnv env pathStrings typeName members i of + Left errorMessage -> + do putStrLnWithColor Red errorMessage + return ctx + Right (typeModuleName, typeModuleXObj, deps) -> + let ctx' = (ctx { contextGlobalEnv = envInsertAt env (SymPath pathStrings typeModuleName) typeModuleXObj + , contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) typeName typeDefinition) + }) + in foldM define ctx' deps DefineAlias name typeXObj -> case xobjToTy typeXObj of @@ -468,16 +480,16 @@ executeCommand ctx@(Context env typeEnv pathStrings proj lastInput) cmd = \http://www.apache.org/licenses/LICENSE-2.0" putStrLn "" putStrLn "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY \n\ - \EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \n\ - \IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR \n\ - \PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE \n\ - \LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR \n\ - \CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF \n\ - \SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR \n\ - \BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, \n\ - \WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE \n\ - \OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN\n\ - \IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." + \EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \n\ + \IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR \n\ + \PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE \n\ + \LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR \n\ + \CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF \n\ + \SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR \n\ + \BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, \n\ + \WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE \n\ + \OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN\n\ + \IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." putStrLn "" return ctx diff --git a/src/Deftype.hs b/src/Deftype.hs index 1cb4122f..5426d562 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -1,4 +1,4 @@ -module Deftype (moduleForDeftype) where +module Deftype (moduleForDeftype, bindingsForRegisteredType) where import qualified Data.Map as Map import Data.Maybe @@ -314,3 +314,22 @@ memberCopy typeEnv env (memberName, memberType) = " copy." ++ memberName ++ " = " ++ functionFullName ++ "(&(pRef->" ++ memberName ++ "));" FunctionNotFound msg -> error msg FunctionIgnored -> " /* Ignore non-managed member '" ++ memberName ++ "' */" + + +-- | Will generate getters/setters/updaters when registering external types +-- | i.e. (register-type VRUnicornData [hp Int, magic Float]) +bindingsForRegisteredType :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe Info -> Either String (String, XObj, [XObj]) +bindingsForRegisteredType typeEnv env pathStrings typeName rest i = + let typeModuleName = typeName + emptyTypeModuleEnv = Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv + insidePath = pathStrings ++ [typeModuleName] + in case validateMembers typeEnv rest of + Left err -> Left err + Right _ -> + case templatesForMembers typeEnv env insidePath typeName rest of + Just (binders, deps) -> + let moduleEnvWithBindings = addListOfBindings emptyTypeModuleEnv binders + typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy) + in return (typeModuleName, typeModuleXObj, deps) + Nothing -> + Left "Something's wrong with the templates..." -- TODO: Better messages here!