fix purescript data codegen

4 files changed, 73 insertions, 31 deletions

diff --git a/Definitions.hs b/Definitions.hs
index 0423123..743c233 100644
--- a/Definitions.hs
+++ b/Definitions.hs
@@ -236,6 +236,7 @@ ir = execWriter $ do
     enum_ "Triangles"
     enum_ "LinesAdjacency"
     enum_ "TrianglesAdjacency"
+    deriving_ [Show,Eq]
 
   data_ "OutputPrimitive" $ do
     enum_ "TrianglesOutput"
@@ -247,6 +248,7 @@ ir = execWriter $ do
     enum_ "RG"
     enum_ "RGB"
     enum_ "RGBA"
+    deriving_ [Show]
 
   data_ "Blending" $ do
     enum_ "NoBlending"
@@ -282,6 +284,7 @@ ir = execWriter $ do
     const_  "IntT"          ["ColorArity"]
     const_  "WordT"         ["ColorArity"]
     enum_   "ShadowT"
+    deriving_ [Show]
 
   data_ "TextureType" $ do
     const_ "Texture1D"      ["TextureDataType", Int]
diff --git a/Generate.hs b/Generate.hs
index d4946fb..a701b22 100644
--- a/Generate.hs
+++ b/Generate.hs
@@ -4,8 +4,9 @@ import           Text.EDE
 import           Text.EDE.Filters
 
 import           Data.HashMap.Strict          (HashMap)
-import qualified Data.HashMap.Strict          as Map
+import qualified Data.HashMap.Strict          as HashMap
 import           Data.Text                    (Text)
+import qualified Data.Map as Map
 
 import Data.Time.Clock
 
@@ -18,17 +19,6 @@ instance Quote [Char]
 instance Unquote DataDef
 instance Unquote Type
 
-mylib :: HashMap Text Term
-mylib = Map.fromList
-    -- boolean
-    [ "hasFieldNames" @: hasFieldNames
-    , "parens"        @: parens
-    , "constType"     @: constType
-    , "hsType"        @: hsType
-    , "psType"        @: psType
-    ]
-
-
 main :: IO ()
 main = do
   irHs <- eitherParseFile "templates/data.hs.ede"
@@ -45,6 +35,17 @@ main = do
               , "moduleName"  .= name
               , "dateTime"    .= dt
               ]
+            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
+                ]
+
         -- Haskell
         either error (\x -> writeFile ("out/" ++ name ++ ".hs") $ LText.unpack x) $ irHs >>= (\t -> eitherRenderWith mylib t env)
         either error (\x -> writeFile ("out/" ++ name ++ "Encode.hs") $ LText.unpack x) $ irEncodeHs >>= (\t -> eitherRenderWith mylib t env)
diff --git a/Language.hs b/Language.hs
index 1950c6e..d4cd1b6 100644
--- a/Language.hs
+++ b/Language.hs
@@ -6,6 +6,8 @@ import Data.Aeson (ToJSON(..),FromJSON(..))
 import Control.Monad.Writer
 import Data.String
 import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
 
 instance IsString Type where
   fromString a = Data a
@@ -14,6 +16,7 @@ data DataDef
   = DataDef
   { dataName      :: String
   , constructors  :: [ConstructorDef]
+  , instances     :: [Instance]
   }
   | TypeAlias
   { aliasName     :: String
@@ -35,6 +38,11 @@ data Field
   }
   deriving (Show,Generic)
 
+data Instance
+  = Show
+  | Eq
+  deriving (Show,Generic)
+
 data Type
   = Int
   | Int32
@@ -60,8 +68,14 @@ parens a
   | 1 == length (words a) = a
   | otherwise = "(" ++ a ++ ")"
 
-psType :: Type -> String
-psType = \case
+type AliasMap = Map String Type
+
+normalize :: AliasMap -> Type -> Type
+normalize aliasMap t@(Data n) = Map.findWithDefault t n aliasMap
+normalize _ t = t
+
+psType :: AliasMap -> Type -> String
+psType aliasMap = \case
   Int     -> "Int"
   Int32   -> "Int32"
   Word    -> "Word"
@@ -94,17 +108,18 @@ psType = \case
   V4 (V3 Float) -> "M34F"
   V4 (V4 Float) -> "M44F"
 
-  Array t       -> "Array " ++ parens (hsType t)
-  List t        -> "List " ++ parens (hsType t)
-  Maybe t       -> "Maybe " ++ parens (hsType t)
-  Map String v  -> "StrMap " ++ parens (hsType v)
-  Map k v       -> "Map " ++ parens (hsType k) ++ " " ++ parens (hsType v)
+  Array t       -> "Array " ++ parens (psType aliasMap t)
+  List t        -> "List " ++ parens (psType aliasMap t)
+  Maybe t       -> "Maybe " ++ parens (psType aliasMap t)
+  Map k v
+    | String <- normalize aliasMap k -> "StrMap " ++ parens (psType aliasMap v)
+    | otherwise -> "Map " ++ parens (psType aliasMap k) ++ " " ++ parens (psType aliasMap v)
   -- user defined
   Data t        -> t
   x -> error $ "unknown type: " ++ show x
 
-hsType :: Type -> String
-hsType = \case
+hsType :: AliasMap -> Type -> String
+hsType aliasMap = \case
   Int     -> "Int"
   Int32   -> "Int32"
   Word    -> "Word"
@@ -137,10 +152,10 @@ hsType = \case
   V4 (V3 Float) -> "M34F"
   V4 (V4 Float) -> "M44F"
 
-  Array t       -> "[" ++ hsType t ++ "]"
-  List t        -> "[" ++ hsType t ++ "]"
-  Maybe t       -> "Maybe " ++ parens (hsType t)
-  Map k v       -> "Map " ++ parens (hsType k) ++ " " ++ parens (hsType v)
+  Array t       -> "[" ++ hsType aliasMap t ++ "]"
+  List t        -> "[" ++ hsType aliasMap t ++ "]"
+  Maybe t       -> "Maybe " ++ parens (hsType aliasMap t)
+  Map k v       -> "Map " ++ parens (hsType aliasMap k) ++ " " ++ parens (hsType aliasMap v)
   -- user defined
   Data t        -> t
   x -> error $ "unknown type: " ++ show x
@@ -154,19 +169,21 @@ constType = head . words . show
 
 instance ToJSON ConstructorDef
 instance ToJSON DataDef
+instance ToJSON Instance
 instance ToJSON Field
 instance ToJSON Type
 
 instance FromJSON ConstructorDef
 instance FromJSON DataDef
+instance FromJSON Instance
 instance FromJSON Field
 instance FromJSON Type
 
 type DDef = Writer [DataDef]
-type CDef = Writer [ConstructorDef]
+type CDef = Writer ([ConstructorDef],[Instance])
 
 data_ :: forall a . String -> CDef () -> DDef ()
-data_ n l = tell [DataDef n $ execWriter l]
+data_ n l = tell [let (c,i) = execWriter l in DataDef n c i]
 
 alias_ :: String -> Type -> DDef ()
 alias_ n t = tell [TypeAlias n t]
@@ -182,14 +199,17 @@ instance IsField Field where
 instance IsField Type where
   toField a = Field "" a
 
+deriving_ :: [Instance] -> CDef ()
+deriving_ l = tell (mempty,l)
+
 const_ :: String -> [Type] -> CDef ()
-const_ n t = tell [ConstructorDef n [Field a b | Field a b <- map toField t]]
+const_ n t = tell ([ConstructorDef n [Field a b | Field a b <- map toField t]],mempty)
 
 constR_ :: String -> [Field] -> CDef ()
-constR_ n t = tell [ConstructorDef n [Field a b | Field a b <- map toField t]]
+constR_ n t = tell ([ConstructorDef n [Field a b | Field a b <- map toField t]],mempty)
 
 enum_ :: String -> CDef ()
-enum_ n = tell [ConstructorDef n []]
+enum_ n = tell ([ConstructorDef n []],mempty)
 
 v2b = V2 Bool
 v3b = V3 Bool
diff --git a/templates/data.purs.ede b/templates/data.purs.ede
index ccaa7de..a26f292 100644
--- a/templates/data.purs.ede
+++ b/templates/data.purs.ede
@@ -2,8 +2,17 @@
 -- {{ dateTime }}
 
 module {{ moduleName }} where
+import Prelude
+import Data.Generic
+import Data.Maybe (Maybe(..))
+import Data.StrMap (StrMap(..))
+import Data.Map (Map(..))
+import Data.List (List(..))
+import Linear
 
-{% for t in definitions %}
+{% for t in dataAndType %}
+{% case t.value | constType %}
+{% when "DataDef" %}
 data {{ t.value.dataName }}{% for c in t.value.constructors %}
 {% if c.value.fields | hasFieldNames %}
   {% if c.first %}={% else %}|{% endif %} {{ c.value.name }}
@@ -13,4 +22,13 @@ data {{ t.value.dataName }}{% for c in t.value.constructors %}
 {% else %}
   {% if c.first %}={% else %}|{% endif %} {{ c.value.name }}{% for f in c.value.fields %} {{ f.value.fieldType | psType | parens }}{% endfor %}{% endif %}{% endfor %}
 
+{% when "TypeAlias" %}
+type {{ t.value.aliasName }} = {{ t.value.aliasType | psType }}
+
+{% endcase %}
 {% endfor %}
+{% for t in definitions %}{% let l = t.value.instances | length %}{% if l > 0 %}{# FIXME!!! #}
+derive instance generic{{ t.value.dataName }} :: Generic {{ t.value.dataName }}
+instance show{{ t.value.dataName }} :: Show {{ t.value.dataName }} where show = gShow
+instance eq{{ t.value.dataName }}   :: Eq {{ t.value.dataName }}   where eq = gEq
+{% endif %}{% endlet %}{% endfor %}