add C++ backend

7 files changed, 278 insertions, 75 deletions

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>(String &v) {
+  return json(v);
+}
+
+template<> json toJSON<Float>(Float &v) {
+  return json(v);
+}
+
+template<> json toJSON<bool>(bool &v) {
+  return json(v);
+}
+
+template<> json toJSON<int>(int &v) {
+  return json(v);
+}
+
+template<> json toJSON<unsigned int>(unsigned int &v) {
+  return json(v);
+}
+
+template<typename any>
+json toJSON(std::vector<any> &v) {
+  json obj = json::array();
+  for (any i : v) {
+    obj.push_back(toJSON(i));
+  }
+  return obj;
+}
+
+template<typename k, typename v>
+json toJSON(std::map<k,v> &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 <vector>
+#include <map>
+#include <string>
+
+#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<typename T>
+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" %}