From 4cf104ca45b4f3f278b3cc8275a9690be3c23fe2 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Wed, 16 Sep 2015 00:41:36 +0200 Subject: add C++ backend --- Definitions.hs | 85 ++++++++++++++++----------------------- Generate.hs | 34 +++++++++------- Language.hs | 105 +++++++++++++++++++++++++++++++++++++++++++++--- templates/data.cpp.ede | 63 +++++++++++++++++++++++++++++ templates/data.hpp.ede | 51 +++++++++++++++++++++++ templates/data.hs.ede | 11 ++--- templates/data.purs.ede | 4 ++ 7 files changed, 278 insertions(+), 75 deletions(-) create mode 100644 templates/data.cpp.ede create mode 100644 templates/data.hpp.ede diff --git a/Definitions.hs b/Definitions.hs index d4b69be..9618407 100644 --- a/Definitions.hs +++ b/Definitions.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -module Definitions where +module Definitions (modules) where import Control.Monad.Writer import Language -ir = execWriter $ do +ir = do -- type aliases "StreamName" #= Int "ProgramName" #= Int @@ -118,6 +118,7 @@ ir = execWriter $ do enum_ "UTexture2DMSArray" enum_ "UTextureBuffer" enum_ "UTexture2DRect" + deriving_ [Haskell] [Eq,Ord] data_ "PointSpriteCoordOrigin" $ do enum_ "LowerLeft" @@ -219,9 +220,6 @@ ir = execWriter $ do , "backStencilOp" #:: "StencilOperation" -- Used for back faced triangles. ] - data_ "StencilTests" $ do - const_ "StencilTests" ["StencilTest", "StencilTest"] - data_ "StencilTest" $ do constR_ "StencilTest" [ "stencilComparision" #:: "ComparisonFunction" -- The function used to compare the @stencilReference@ and the stencil buffers value with. @@ -229,6 +227,9 @@ ir = execWriter $ do , "stencilMask" #:: Word32 -- A bit mask with ones in each position that should be compared and written to the stencil buffer. ] + data_ "StencilTests" $ do + const_ "StencilTests" ["StencilTest", "StencilTest"] + -- primitive types data_ "FetchPrimitive" $ do enum_ "Points" @@ -236,7 +237,7 @@ ir = execWriter $ do enum_ "Triangles" enum_ "LinesAdjacency" enum_ "TrianglesAdjacency" - deriving_ [Show,Eq] + deriving_ [PureScript] [Show,Eq] data_ "OutputPrimitive" $ do enum_ "TrianglesOutput" @@ -248,7 +249,7 @@ ir = execWriter $ do enum_ "RG" enum_ "RGB" enum_ "RGBA" - deriving_ [Show] + deriving_ [PureScript] [Show] data_ "Blending" $ do enum_ "NoBlending" @@ -284,7 +285,7 @@ ir = execWriter $ do const_ "IntT" ["ColorArity"] const_ "WordT" ["ColorArity"] enum_ "ShadowT" - deriving_ [Show] + deriving_ [PureScript] [Show] data_ "TextureType" $ do const_ "Texture1D" ["TextureDataType", Int] @@ -314,14 +315,15 @@ ir = execWriter $ do enum_ "ClampToEdge" enum_ "ClampToBorder" - data_ "ImageRef" $ do - const_ "TextureImage" ["TextureName", Int, Maybe Int] -- Texture name, mip index, array index - const_ "Framebuffer" ["ImageSemantic"] - data_ "ImageSemantic" $ do enum_ "Depth" enum_ "Stencil" enum_ "Color" + deriving_ [Haskell] [Eq] + + data_ "ImageRef" $ do + const_ "TextureImage" ["TextureName", Int, Maybe Int] -- Texture name, mip index, array index + const_ "Framebuffer" ["ImageSemantic"] data_ "ClearImage" $ do constR_ "ClearImage" @@ -344,16 +346,6 @@ ir = execWriter $ do const_ "SaveImage" ["FrameBufferComponent", "ImageRef"] -- from framebuffer component to texture (image) const_ "LoadImage" ["ImageRef", "FrameBufferComponent"] -- from texture (image) to framebuffer component - data_ "TextureDescriptor" $ do -- texture size, type, array, mipmap - constR_ "TextureDescriptor" - [ "textureType" #:: "TextureType" - , "textureSize" #:: "Value" - , "textureSemantic" #:: "ImageSemantic" - , "textureSampler" #:: "SamplerDescriptor" - , "textureBaseLevel" #:: Int - , "textureMaxLevel" #:: Int - ] - data_ "SamplerDescriptor" $ do constR_ "SamplerDescriptor" [ "samplerWrapS" #:: "EdgeMode" @@ -368,6 +360,16 @@ ir = execWriter $ do , "samplerCompareFunc" #:: Maybe "ComparisonFunction" ] + data_ "TextureDescriptor" $ do -- texture size, type, array, mipmap + constR_ "TextureDescriptor" + [ "textureType" #:: "TextureType" + , "textureSize" #:: "Value" + , "textureSemantic" #:: "ImageSemantic" + , "textureSampler" #:: "SamplerDescriptor" + , "textureBaseLevel" #:: Int + , "textureMaxLevel" #:: Int + ] + data_ "Parameter" $ do constR_ "Parameter" [ "name" #:: String @@ -428,8 +430,9 @@ ir = execWriter $ do , "streams" #:: Array "StreamData" , "commands" #:: Array "Command" ] + deriving_ [Haskell] [Show] -mesh = execWriter $ do +mesh = do data_ "MeshAttribute" $ do const_ "A_Float" [Array Float] const_ "A_V2F" [Array v2f] @@ -454,7 +457,7 @@ mesh = execWriter $ do , "mPrimitive" #:: "MeshPrimitive" ] -typeInfo = execWriter $ do +typeInfo = do data_ "TypeInfo" $ do constR_ "TypeInfo" [ "startLine" #:: Int @@ -466,29 +469,11 @@ typeInfo = execWriter $ do data_ "MyEither" $ do const_ "MyLeft" ["TypeInfo", Array "TypeInfo"] - const_ "MyRight" ["TypeInfo"{- "Pipeline" -}, Array "TypeInfo"] - -{- -type TypeInfoRecord = - { startLine :: Int - , startColumn :: Int - , endLine :: Int - , endColumn :: Int - , text :: String - } -data TypeInfo = TypeInfo TypeInfoRecord - -instance decodeJsonTypeInfo :: DecodeJson TypeInfo where - decodeJson json = do - obj <- decodeJson json - startL <- obj .? "startL" - startC <- obj .? "startC" - endL <- obj .? "endL" - endC <- obj .? "endC" - text <- obj .? "text" - return $ TypeInfo {startLine:startL, startColumn:startC, endLine:endL, endColumn:endC, text:text} - -data MyEither - = MyLeft TypeInfo (Array TypeInfo) - | MyRight Pipeline (Array TypeInfo) --} \ No newline at end of file + const_ "MyRight" ["Pipeline", Array "TypeInfo"] + +modules = do + module_ "IR" ir + module_ "Mesh" mesh + module_ "TypeInfo" $ do + import_ ["IR"] + typeInfo diff --git a/Generate.hs b/Generate.hs index 8bc725f..3b5bb0e 100644 --- a/Generate.hs +++ b/Generate.hs @@ -9,6 +9,7 @@ import Data.Text (Text) import qualified Data.Map as Map import Data.Time.Clock +import Control.Monad.Writer import Definitions import Language @@ -21,31 +22,36 @@ instance Unquote Type main :: IO () main = do - irHs <- eitherParseFile "templates/data.hs.ede" - irPs <- eitherParseFile "templates/data.purs.ede" - let generate name def = do + dataHpp <- eitherParseFile "templates/data.hpp.ede" + dataCpp <- eitherParseFile "templates/data.cpp.ede" + dataHs <- eitherParseFile "templates/data.hs.ede" + dataPs <- eitherParseFile "templates/data.purs.ede" + let generate (ModuleDef name imports def) = do dt <- getCurrentTime let env = fromPairs [ "dataAndType" .= def , "definitions" .= [a | a@DataDef{} <- def ] , "moduleName" .= name , "dateTime" .= dt + , "imports" .= imports ] aliasMap = Map.fromList [(n,t) | TypeAlias n t <- def] mylib :: HashMap Text Term mylib = HashMap.fromList - -- boolean - [ "hasFieldNames" @: hasFieldNames - , "parens" @: parens - , "constType" @: constType - , "hsType" @: hsType aliasMap - , "psType" @: psType aliasMap + [ "hasFieldNames" @: hasFieldNames + , "parens" @: parens + , "constType" @: constType + , "hsType" @: hsType aliasMap + , "psType" @: psType aliasMap + , "cppType" @: cppType aliasMap + , "mangleTypeName" @: mangleTypeName aliasMap ] -- Haskell - either error (\x -> writeFile ("out/" ++ name ++ ".hs") $ LText.unpack x) $ irHs >>= (\t -> eitherRenderWith mylib t env) + either error (\x -> writeFile ("out/" ++ name ++ ".hs") $ LText.unpack x) $ dataHs >>= (\t -> eitherRenderWith mylib t env) -- Purescript - either error (\x -> writeFile ("out/" ++ name ++ ".purs") $ LText.unpack x) $ irPs >>= (\t -> eitherRenderWith mylib t env) - generate "IR" ir - generate "Mesh" mesh - generate "TypeInfo" typeInfo + either error (\x -> writeFile ("out/" ++ name ++ ".purs") $ LText.unpack x) $ dataPs >>= (\t -> eitherRenderWith mylib t env) + -- C++ + either error (\x -> writeFile ("out/" ++ name ++ ".hpp") $ LText.unpack x) $ dataHpp >>= (\t -> eitherRenderWith mylib t env) + either error (\x -> writeFile ("out/" ++ name ++ ".cpp") $ LText.unpack x) $ dataCpp >>= (\t -> eitherRenderWith mylib t env) + mapM_ generate $ execWriter modules diff --git a/Language.hs b/Language.hs index 15780f6..1a2385d 100644 --- a/Language.hs +++ b/Language.hs @@ -12,6 +12,14 @@ import qualified Data.Map as Map instance IsString Type where fromString a = Data a +data ModuleDef + = ModuleDef + { moduleName :: String + , imports :: [String] + , definitions :: [DataDef] + } + deriving (Show,Generic) + data DataDef = DataDef { dataName :: String @@ -41,6 +49,13 @@ data Field data Instance = Show | Eq + | Ord + deriving (Show,Generic) + +data Target + = Haskell + | PureScript + | Cpp deriving (Show,Generic) data Type @@ -160,6 +175,77 @@ hsType aliasMap = \case Data t -> t x -> error $ "unknown type: " ++ show x +cppType :: AliasMap -> Type -> String +cppType aliasMap = \case + Data t -> "::" ++ t + Int -> "Int" + Int32 -> "Int32" + Word -> "Word" + Word32 -> "Word32" + Float -> "Float" + Bool -> "Bool" + String -> "String" + Array t -> "std::vector<" ++ cppType aliasMap t ++ ">" + List t -> "std::vector<" ++ cppType aliasMap t ++ ">" + Map k v -> "std::map<" ++ cppType aliasMap k ++ ", " ++ cppType aliasMap v ++ ">" + _ -> "int" +{- + Int -> "Int" + Int32 -> "Int32" + Word -> "Word" + Word32 -> "Word32" + Float -> "Float" + Bool -> "Bool" + String -> "String" + + V2 Int -> "V2I" + V2 Word -> "V2U" + V2 Float -> "V2F" + V2 Bool -> "V2B" + V2 (V2 Float) -> "M22F" + V2 (V3 Float) -> "M32F" + V2 (V4 Float) -> "M42F" + + V3 Int -> "V3I" + V3 Word -> "V3U" + V3 Float -> "V3F" + V3 Bool -> "V3B" + V3 (V2 Float) -> "M23F" + V3 (V3 Float) -> "M33F" + V3 (V4 Float) -> "M43F" + + V4 Int -> "V4I" + V4 Word -> "V4U" + V4 Float -> "V4F" + V4 Bool -> "V4B" + V4 (V2 Float) -> "M24F" + V4 (V3 Float) -> "M34F" + V4 (V4 Float) -> "M44F" + + Array t -> "Vector " ++ parens (cppType aliasMap t) + List t -> "[" ++ cppType aliasMap t ++ "]" + Maybe t -> "Maybe " ++ parens (cppType aliasMap t) + Map k v -> "Map " ++ parens (cppType aliasMap k) ++ " " ++ parens (cppType aliasMap v) + -- user defined + Data t -> t + x -> error $ "unknown type: " ++ show x +-} + +mangleTypeName :: AliasMap -> Type -> String +mangleTypeName aliasMap t = case normalize aliasMap t of +{- + Int -> "Int" + Int32 -> "Int32" + Word -> "Word" + Word32 -> "Word32" + Float -> "Float" + Bool -> "Bool" + String -> "String" +-} + -- user defined + Data t -> "ToJSON" + t -> cppType aliasMap t + hasFieldNames :: [Field] -> Bool hasFieldNames [] = False hasFieldNames l = all (not . null . fieldName) l @@ -179,14 +265,21 @@ instance FromJSON Instance instance FromJSON Field instance FromJSON Type -type DDef = Writer [DataDef] +type MDef = Writer [ModuleDef] +type DDef = Writer ([DataDef],[String]) type CDef = Writer ([ConstructorDef],[Instance]) -data_ :: forall a . String -> CDef () -> DDef () -data_ n l = tell [let (c,i) = execWriter l in DataDef n c i] +module_ :: String -> DDef () -> MDef () +module_ n m = tell [let (d,i) = execWriter m in ModuleDef n i d] + +import_ :: [String] -> DDef () +import_ l = tell (mempty,l) + +data_ :: String -> CDef () -> DDef () +data_ n l = tell ([let (c,i) = execWriter l in DataDef n c i],mempty) alias_ :: String -> Type -> DDef () -alias_ n t = tell [TypeAlias n t] +alias_ n t = tell ([TypeAlias n t],mempty) a #= b = alias_ a b @@ -199,8 +292,8 @@ instance IsField Field where instance IsField Type where toField a = Field "" a -deriving_ :: [Instance] -> CDef () -deriving_ l = tell (mempty,l) +deriving_ :: [Target] -> [Instance] -> CDef () +deriving_ t l = tell (mempty,l) const_ :: String -> [Type] -> CDef () const_ n t = tell ([ConstructorDef n [Field a b | Field a b <- map toField t]],mempty) diff --git a/templates/data.cpp.ede b/templates/data.cpp.ede new file mode 100644 index 0000000..8e106a6 --- /dev/null +++ b/templates/data.cpp.ede @@ -0,0 +1,63 @@ +// generated file, do not modify! +// {{ dateTime }} + +#include "{{ moduleName }}.hpp" + +template<> json toJSON(String &v) { + return json(v); +} + +template<> json toJSON(Float &v) { + return json(v); +} + +template<> json toJSON(bool &v) { + return json(v); +} + +template<> json toJSON(int &v) { + return json(v); +} + +template<> json toJSON(unsigned int &v) { + return json(v); +} + +template +json toJSON(std::vector &v) { + json obj = json::array(); + for (any i : v) { + obj.push_back(toJSON(i)); + } + return obj; +} + +template +json toJSON(std::map &value) { + return json(); +} + +{% for t in definitions %} +template<> json toJSON<{{ t.value.dataName }}>({{ t.value.dataName }} &v) { + json obj; + switch (v.tag) { {% for c in t.value.constructors %} + case ::{{ t.value.dataName }}::tag::{{ c.value.name }}: + obj["tag"] = "{{ c.value.name }}";{% if !(c.value.fields | empty) %} + { + auto tv = static_cast<::data::{{ c.value.name }}&>(v);{% for f in c.value.fields %}{% if c.value.fields | hasFieldNames %} + obj["{{ f.value.fieldName }}"] = toJSON(tv.{{ f.value.fieldName }});{% else %} + obj["arg{{ f.index0 }}"] = toJSON(tv._{{ f.index0 }});{% endif %}{% endfor %} + }{% endif %} + break;{% endfor %} + } + return obj; +} +{% endfor %} + +{# +{% for c in t.value.constructors %} +json data::{{ c.value.name }}::toJSON() { + return obj; +} +{% endif %}{% endfor %}{% endfor %} +#} \ No newline at end of file diff --git a/templates/data.hpp.ede b/templates/data.hpp.ede new file mode 100644 index 0000000..10e1ff4 --- /dev/null +++ b/templates/data.hpp.ede @@ -0,0 +1,51 @@ +// generated file, do not modify! +// {{ dateTime }} + +#ifndef HEADER_{{ moduleName }}_H +#define HEADER_{{ moduleName }}_H + +#include +#include +#include + +#include "json.hpp" + +typedef int Int; +typedef int Int32; +typedef unsigned int Word; +typedef unsigned int Word32; +typedef float Float; +typedef bool Bool; +typedef std::string String; + +using json = nlohmann::json; + +template +json toJSON(T &v); + +{% for m in imports %} +#include "{{ m.value }}.hpp" +{% endfor %} + +{% for t in dataAndType %} +{% case t.value | constType %} +{% when "DataDef" %} +class {{ t.value.dataName }} { + public: + enum class tag { {% for c in t.value.constructors %} + {{ c.value.name }}{% if !c.last %},{% endif %}{% endfor %} + } tag; +}; +namespace data { {% for c in t.value.constructors %}{% if !(c.value.fields | empty) %} + class {{ c.value.name }} : public ::{{ t.value.dataName }} { + public:{% for f in c.value.fields %}{% if c.value.fields | hasFieldNames %} + {{ f.value.fieldType | cppType }} {{ f.value.fieldName }};{% else %} + {{ f.value.fieldType | cppType | parens }} _{{ f.index0 }};{% endif %}{% endfor %} + };{% endif %}{% endfor %} +} +{% when "TypeAlias" %} +typedef {{ t.value.aliasType | cppType }} {{ t.value.aliasName }}; + +{% endcase %} +{% endfor %} +#endif diff --git a/templates/data.hs.ede b/templates/data.hs.ede index fccd7dc..54a148b 100644 --- a/templates/data.hs.ede +++ b/templates/data.hs.ede @@ -15,6 +15,10 @@ import Data.Aeson hiding (Value,Bool) import Data.Aeson.Types hiding (Value,Bool) import Control.Monad +{% for m in imports %} +import {{ m.value }} +{% endfor %} + {% for t in dataAndType %} {% case t.value | constType %} {% when "DataDef" %} @@ -33,17 +37,14 @@ type {{ t.value.aliasName }} = {{ t.value.aliasType | hsType }} {% endfor %} -(.-) :: Text -> Text -> Pair -a .- b = a .= b - {% for t in definitions %} instance ToJSON {{ t.value.dataName }} where toJSON v = case v of{% for c in t.value.constructors %}{% if c.value.fields | hasFieldNames %} {{ c.value.name }}{..} -> object - [ "tag" .- "{{ c.value.name }}"{% for f in c.value.fields %} + [ "tag" .= ("{{ c.value.name }}" :: Text){% for f in c.value.fields %} , "{{ f.value.fieldName }}" .= {{ f.value.fieldName }}{% endfor %} ]{% else %} - {{ c.value.name }}{% for f in c.value.fields %} arg{{ f.index0 }}{% endfor %} -> object [ "tag" .- "{{ c.value.name }}"{% for f in c.value.fields %}, "arg{{ f.index0 }}" .= arg{{ f.index0 }}{% endfor %}]{% endif %}{% endfor %} + {{ c.value.name }}{% for f in c.value.fields %} arg{{ f.index0 }}{% endfor %} -> object [ "tag" .= ("{{ c.value.name }}" :: Text){% for f in c.value.fields %}, "arg{{ f.index0 }}" .= arg{{ f.index0 }}{% endfor %}]{% endif %}{% endfor %} instance FromJSON {{ t.value.dataName }} where parseJSON (Object obj) = do diff --git a/templates/data.purs.ede b/templates/data.purs.ede index 957fff4..0474931 100644 --- a/templates/data.purs.ede +++ b/templates/data.purs.ede @@ -16,6 +16,10 @@ import Data.Argonaut.Printer (printJson) import Data.Argonaut.Encode (EncodeJson, encodeJson) import Data.Argonaut.Decode (DecodeJson, decodeJson) +{% for m in imports %} +import {{ m.value }} +{% endfor %} + {% for t in dataAndType %} {% case t.value | constType %} {% when "DataDef" %} -- cgit v1.2.3