[hoc-cvs] [hoc commit] r334 - trunk/hoc/InterfaceGenerator2

[<cod...@go...>]

Author: wol...@gm...
Date: Tue Oct  7 16:55:09 2008
New Revision: 334

Modified:
    trunk/hoc/InterfaceGenerator2/BuildEntities.hs
    trunk/hoc/InterfaceGenerator2/Entities.hs
    trunk/hoc/InterfaceGenerator2/Output.hs
    trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs

Log:
automatically import struct types


Modified: trunk/hoc/InterfaceGenerator2/BuildEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BuildEntities.hs	(original)
+++ trunk/hoc/InterfaceGenerator2/BuildEntities.hs	Tue Oct  7 16:55:09 2008
@@ -223,8 +223,19 @@
                          eSrcPos = pos
                      }
                ) >> return ()
-        makeEntity _modName (pos, Typedef (CTStruct _n2 _fields) _name)
-            = return ()
+        makeEntity modName (pos, Typedef (CTStruct n2 fields) name)
+            = do
+                newEntity $ Entity {
+                        eName = CName $ BS.pack name,
+                        eHaskellName = getName name (nameToUppercase name),
+                        eAlternateHaskellNames = [],
+                        eInfo = StructEntity mbTag $ map  
(UnconvertedType . fst) fields,
+                        eModule = LocalModule modName,
+                        eSrcPos = pos
+                    }
+                return ()
+            where
+                mbTag = if n2 == "" then Nothing else Just n2
          makeEntity _modName (pos, Typedef (CTUnion _n2 _fields) _name)
              = return ()
          makeEntity modName (pos, Typedef (CTEnum _n2 vals) name)

Modified: trunk/hoc/InterfaceGenerator2/Entities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Entities.hs	(original)
+++ trunk/hoc/InterfaceGenerator2/Entities.hs	Tue Oct  7 16:55:09 2008
@@ -57,6 +57,8 @@
                             ByteString {- import statements -}
                             ByteString {- text -}

+    | StructEntity (Maybe String) [HaskellValueType]
+
      deriving ( Read, Show, Eq, Ord, Typeable, Data )

  data Name

Modified: trunk/hoc/InterfaceGenerator2/Output.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Output.hs	(original)
+++ trunk/hoc/InterfaceGenerator2/Output.hs	Tue Oct  7 16:55:09 2008
@@ -38,6 +38,8 @@
              where
                  lowercaseNames = map (BS.pack . nameToLowercase .  
BS.unpack . fst) values

+        StructEntity _ _ -> [eHaskellName e `BS.append` BS.pack "(..)"]
+
          AdditionalCodeEntity _ exp _ _ -> exp

          _ -> case eName e of
@@ -213,6 +215,23 @@
                      Anonymous   -> text "declareAnonymousCEnum"
                  pprAssoc (n, v)
                      = parens (doubleQuotes (textBS n) <> comma <+> integer  
v)
+
+        pprEntity e@(Entity { eInfo = StructEntity mbTag fields })
+            = char '$' <> parens (
+                    declare <+> brackets (
+                        hcat $ punctuate comma $ map pprType fields
+                    )
+                )
+            where
+                declare = case eName e of
+                    CName cname -> text "declareCStructWithTag"
+                                    <+> doubleQuotes (textBS cname)
+                                    <+> tag
+                tag = case mbTag of Nothing -> text "Prelude.Nothing"
+                                    Just t -> parens (text "Prelude.Just"  
<+> doubleQuotes (text t))
+
+                pprType t = text "[t|" <+> pprVariableType ht <+> text "|]"
+                    where ConvertedType ht _ = t

          pprEntity e@(Entity { eInfo = AdditionalCodeEntity _ _ _ txt })
              = textBS txt

Modified: trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs	(original)
+++ trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs	Tue Oct  7 16:55:09 2008
@@ -74,6 +74,7 @@
                      TypeSynonymEntity _ -> Just PlainTypeName
                      AdditionalTypeEntity -> Just PlainTypeName
                      EnumEntity _ _ -> Just PlainTypeName
+                    StructEntity _ _ -> Just PlainTypeName
                      ClassEntity _ -> Just ClassTypeName
                      _ -> Nothing