mirror of
https://github.com/carp-lang/Carp.git
synced 2024-10-11 20:49:05 +03:00
Can define member getter/setters/updaters for external structs.
This commit is contained in:
parent
ff65b37925
commit
ad24d7dad8
@ -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' "")
|
||||
|
||||
|
10
examples/banana.h
Normal file
10
examples/banana.h
Normal file
@ -0,0 +1,10 @@
|
||||
#ifndef BANANA_H
|
||||
#define BANANA_H
|
||||
|
||||
// This is an example external struct
|
||||
|
||||
typedef struct {
|
||||
double price;
|
||||
} Banana;
|
||||
|
||||
#endif
|
@ -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)))))
|
||||
|
@ -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
|
||||
|
@ -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!
|
||||
|
Loading…
Reference in New Issue
Block a user