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)
|
context' <- foldM executeCommand context (map Load args)
|
||||||
settings <- readlineSettings
|
settings <- readlineSettings
|
||||||
runInputT settings (repl context' "")
|
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 IO)
|
||||||
(use Int)
|
;;(use Int)
|
||||||
;; (use Float)
|
;; (use Float)
|
||||||
;; (use Double)
|
;; (use Double)
|
||||||
;; (use Array)
|
;; (use Array)
|
||||||
@ -8,8 +8,11 @@
|
|||||||
;; (use Char)
|
;; (use Char)
|
||||||
;; (use Bool)
|
;; (use Bool)
|
||||||
|
|
||||||
(defn reducer [x y]
|
(local-include "../examples/banana.h")
|
||||||
(Int.+ @x @y))
|
|
||||||
|
|
||||||
(defn f [xs]
|
(register-type Apple)
|
||||||
(Array.reduce reducer 0 xs))
|
(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
|
data ReplCommand = Define XObj
|
||||||
| AddInclude Includer
|
| AddInclude Includer
|
||||||
| Register String XObj
|
| Register String XObj
|
||||||
| RegisterType String
|
| RegisterType String [XObj]
|
||||||
| AddCFlag String
|
| AddCFlag String
|
||||||
| AddLibraryFlag String
|
| AddLibraryFlag String
|
||||||
| DefineModule String [XObj] (Maybe Info)
|
| 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 _ "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 _ "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")) _ _ : 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 _ "local-include")) _ _ : XObj (Str file) _ _ : [] -> AddInclude (LocalInclude file)
|
||||||
XObj (Sym (SymPath _ "system-include")) _ _ : XObj (Str file) _ _ : [] -> AddInclude (SystemInclude file)
|
XObj (Sym (SymPath _ "system-include")) _ _ : XObj (Str file) _ _ : [] -> AddInclude (SystemInclude file)
|
||||||
XObj (Sym (SymPath _ "add-cflag")) _ _ : XObj (Str flag) _ _ : [] -> AddCFlag flag
|
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 ++ "'")
|
Nothing -> do putStrLnWithColor Red ("Can't understand type when registering '" ++ name ++ "'")
|
||||||
return ctx
|
return ctx
|
||||||
|
|
||||||
RegisterType name ->
|
RegisterType typeName rest ->
|
||||||
let path = SymPath pathStrings name
|
let path = SymPath pathStrings typeName
|
||||||
binding = XObj (Lst [XObj ExternalType Nothing Nothing, XObj (Sym path) Nothing Nothing]) Nothing (Just TypeTy)
|
typeDefinition = XObj (Lst [XObj ExternalType Nothing Nothing, XObj (Sym path) Nothing Nothing]) Nothing (Just TypeTy)
|
||||||
typeEnv' = TypeEnv (envInsertAt (getTypeEnv typeEnv) path binding)
|
i = Nothing
|
||||||
in return (ctx { contextTypeEnv = typeEnv' })
|
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 ->
|
DefineAlias name typeXObj ->
|
||||||
case xobjToTy typeXObj of
|
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"
|
\http://www.apache.org/licenses/LICENSE-2.0"
|
||||||
putStrLn ""
|
putStrLn ""
|
||||||
putStrLn "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY \n\
|
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\
|
\EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \n\
|
||||||
\IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR \n\
|
\IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR \n\
|
||||||
\PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE \n\
|
\PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE \n\
|
||||||
\LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR \n\
|
\LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR \n\
|
||||||
\CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF \n\
|
\CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF \n\
|
||||||
\SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR \n\
|
\SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR \n\
|
||||||
\BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, \n\
|
\BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, \n\
|
||||||
\WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE \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\
|
\OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN\n\
|
||||||
\IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE."
|
\IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE."
|
||||||
putStrLn ""
|
putStrLn ""
|
||||||
return ctx
|
return ctx
|
||||||
|
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
module Deftype (moduleForDeftype) where
|
module Deftype (moduleForDeftype, bindingsForRegisteredType) where
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
@ -314,3 +314,22 @@ memberCopy typeEnv env (memberName, memberType) =
|
|||||||
" copy." ++ memberName ++ " = " ++ functionFullName ++ "(&(pRef->" ++ memberName ++ "));"
|
" copy." ++ memberName ++ " = " ++ functionFullName ++ "(&(pRef->" ++ memberName ++ "));"
|
||||||
FunctionNotFound msg -> error msg
|
FunctionNotFound msg -> error msg
|
||||||
FunctionIgnored -> " /* Ignore non-managed member '" ++ memberName ++ "' */"
|
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