gidl: start major refactor to make structs not contain structs

gidl.cabal

@@ -9,23 +9,23 @@ build-type:          Simple
 cabal-version:       >=1.10
 
 library
-  exposed-modules:     Gidl,
-                       Gidl.Parse,
+  exposed-modules:     Gidl.Parse,
                        Gidl.Interface,
                        Gidl.Interface.AST,
                        Gidl.Schema,
                        Gidl.Types,
                        Gidl.Types.AST,
                        Gidl.Types.Base,
-                       Gidl.Backend.Cabal,
-                       Gidl.Backend.Haskell,
-                       Gidl.Backend.Haskell.Interface,
-                       Gidl.Backend.Haskell.Test,
-                       Gidl.Backend.Haskell.Types,
-                       Gidl.Backend.Ivory,
-                       Gidl.Backend.Ivory.Interface,
-                       Gidl.Backend.Ivory.Test,
-                       Gidl.Backend.Ivory.Types
+                       Gidl.Backend.Cabal
+                     --  Gidl,
+                     --  Gidl.Backend.Haskell,
+                     --  Gidl.Backend.Haskell.Interface,
+                     --  Gidl.Backend.Haskell.Test,
+                     --  Gidl.Backend.Haskell.Types,
+                     --  Gidl.Backend.Ivory,
+                     --  Gidl.Backend.Ivory.Interface,
+                     --  Gidl.Backend.Ivory.Test,
+                     --  Gidl.Backend.Ivory.Types
 
   build-depends:       base >=4.7 && <4.8,
                        hashable,

src/Gidl/Interface.hs

@@ -1,9 +1,6 @@
 
 module Gidl.Interface
   ( module Gidl.Interface.AST
-  , InterfaceDescr
-  , InterfaceRepr(..)
-  , interfaceDescrToRepr
   , lookupInterface
   , insertInterface
   , interfaceParents
@@ -12,50 +9,28 @@ module Gidl.Interface
   ) where
 
 import Data.List (nub)
-import Data.Maybe (fromJust)
 import Gidl.Interface.AST
 import Gidl.Types
 
-type InterfaceDescr = Interface InterfaceName TypeName
-
-lookupInterface :: InterfaceName -> InterfaceEnv -> Maybe InterfaceDescr
+lookupInterface :: InterfaceName -> InterfaceEnv -> Maybe Interface
 lookupInterface iname (InterfaceEnv ie) = lookup iname ie
 
-insertInterface :: InterfaceName -> InterfaceDescr -> InterfaceEnv -> InterfaceEnv
+insertInterface :: InterfaceName -> Interface -> InterfaceEnv -> InterfaceEnv
 insertInterface iname i e@(InterfaceEnv ie) = case lookupInterface iname e of
   Nothing -> InterfaceEnv ((iname,i):ie)
   Just _ -> error ("insertInterface invariant broken: interface " ++ iname ++ "already exists")
 
-interfaceParents :: Interface i t -> [i]
+interfaceParents :: Interface -> [Interface]
 interfaceParents (Interface parents _) = parents
 
-interfaceTypes :: InterfaceRepr -> [TypeRepr]
+interfaceTypes :: Interface -> [Type]
 interfaceTypes ir = nub (map (methodT . snd) ms)
   where
   ms = interfaceMethods ir
-  methodT :: Method TypeRepr -> TypeRepr
-  methodT (AttrMethod _ tr) = tr
-  methodT (StreamMethod _ tr) = tr
-
-
-data InterfaceRepr = InterfaceRepr InterfaceName (Interface InterfaceRepr TypeRepr)
-                     deriving (Eq, Show)
-
-interfaceDescrToRepr :: InterfaceName -> InterfaceEnv -> TypeEnv -> InterfaceRepr
-interfaceDescrToRepr iname ie te = InterfaceRepr iname ir
-  where
-  ir = case fromJust $ lookupInterface iname ie of
-      Interface is ms -> Interface (map recur is)
-                           [ (mn, methodDescrToRepr te md) | (mn, md) <- ms ]
-  recur i = interfaceDescrToRepr i ie te
-
+  methodT :: Method -> Type
+  methodT (AttrMethod _ ty) = ty
+  methodT (StreamMethod _ ty) = ty
 
-methodDescrToRepr :: TypeEnv -> Method TypeName -> Method TypeRepr
-methodDescrToRepr te (AttrMethod p tn) = AttrMethod p (typeDescrToRepr tn te)
-methodDescrToRepr te (StreamMethod r tn) = StreamMethod r (typeDescrToRepr tn te)
-
-interfaceMethods :: InterfaceRepr -> [(MethodName, Method TypeRepr)]
-interfaceMethods ir = ms ++ concatMap interfaceMethods ps
-  where
-  (InterfaceRepr _ (Interface ps ms)) =  ir
+interfaceMethods :: Interface -> [(MethodName, Method)]
+interfaceMethods (Interface ps ms) = ms ++ concatMap interfaceMethods ps
 

src/Gidl/Interface/AST.hs

@@ -4,7 +4,7 @@ module Gidl.Interface.AST where
 import Gidl.Types.AST
 
 data InterfaceEnv
-  = InterfaceEnv [(InterfaceName, Interface InterfaceName TypeName)]
+  = InterfaceEnv [(InterfaceName, Interface)]
   deriving (Eq, Show)
 
 emptyInterfaceEnv :: InterfaceEnv
@@ -13,13 +13,13 @@ emptyInterfaceEnv = InterfaceEnv []
 type InterfaceName = String
 type MethodName = String
 
-data Interface i t
-  = Interface [i] [(MethodName, Method t)]
+data Interface
+  = Interface [Interface] [(MethodName, Method)]
   deriving (Eq, Show)
 
-data Method t
-  = AttrMethod Perm t
-  | StreamMethod Integer t
+data Method
+  = AttrMethod Perm Type
+  | StreamMethod Integer Type
   deriving (Eq, Show)
 
 data Perm

src/Gidl/Parse.hs

@@ -91,54 +91,61 @@ tPair a b = tList $ do
   rb <- b
   return (ra, rb)
 
-tKnownTypeName :: Parser ParseEnv TypeName
-tKnownTypeName = do
+tKnownPrimType  :: Parser ParseEnv PrimType
+tKnownPrimType  = do
+  t <- tKnownType
+  case t of
+    PrimType p -> return p
+    StructType n _ -> fail ("expected a known primitive type name, got " ++ n)
+
+tKnownType :: Parser ParseEnv Type
+tKnownType = do
   s <- tSymbol
   te <- getTypeEnv
   case lookupTypeName s te of
-    Just _ -> return s
+    Just t -> return t
     Nothing -> fail ("expected a known type name, got " ++ s)
 
-tStructRow :: Parser ParseEnv (Identifier, TypeName)
-tStructRow = tPair tSymbol tKnownTypeName
+tStructRow :: Parser ParseEnv (Identifier, PrimType)
+tStructRow = tPair tSymbol tKnownPrimType
   <?> "struct row"
 
-tStructBody :: Parser ParseEnv [(Identifier, TypeName)]
+tStructBody :: Parser ParseEnv [(Identifier, PrimType)]
 tStructBody = tList (many1 (tWhiteSpace >> tStructRow))
   <?> "struct body"
 
-tStructDecl :: Parser ParseEnv (TypeName, TypeDescr)
+tStructDecl :: Parser ParseEnv (TypeName, Type)
 tStructDecl = tList $ do
   tIdentifier "def-struct"
   tWhiteSpace
   n <- tSymbol
   b <- tStructBody
-  return (n, StructType (Struct b))
+  return (n, StructType n b)
 
-defineType :: (TypeName, TypeDescr) -> Parser ParseEnv ()
+defineType :: (TypeName, Type) -> Parser ParseEnv ()
 defineType (tn, t) = do
   te <- getTypeEnv
   case lookupTypeName tn te of
     Just _ -> fail ("type named '" ++ tn ++ "' already exists")
     Nothing -> setTypeEnv (insertType tn t te)
 
-defineInterface :: (InterfaceName, InterfaceDescr) -> Parser ParseEnv ()
+defineInterface :: (InterfaceName, Interface) -> Parser ParseEnv ()
 defineInterface (ina, i) = do
   ie <- getInterfaceEnv
   case lookupInterface ina ie of
     Just _ -> fail ("interface named '" ++ ina ++ "' already exists")
     Nothing -> setInterfaceEnv (insertInterface ina i ie)
 
-tNewtypeDecl :: Parser ParseEnv (TypeName, TypeDescr)
+tNewtypeDecl :: Parser ParseEnv (TypeName, Type)
 tNewtypeDecl = tList $ do
   tIdentifier "def-newtype"
   tWhiteSpace
   n <- tSymbol
   tWhiteSpace
-  c <- tKnownTypeName
-  return (n, NewtypeType (Newtype c))
+  c <- tKnownPrimType
+  return (n, PrimType (Newtype n c))
 
-tEnumDecl :: Parser ParseEnv (TypeName, TypeDescr)
+tEnumDecl :: Parser ParseEnv (TypeName, Type)
 tEnumDecl = tList $ do
   tIdentifier "def-enum"
   tWhiteSpace
@@ -158,7 +165,7 @@ tEnumDecl = tList $ do
   when (not_unique (map snd vs)) $
     fail "enum values were not unique"
   -- XXX make it possible to implicitly assign numbers
-  return (n, EnumType (EnumT width vs))
+  return (n, PrimType (EnumType n width vs))
 
 not_unique :: (Eq a) => [a] -> Bool
 not_unique l = nub l /= l
@@ -175,7 +182,7 @@ tPermission = do
     "rw"        -> return ReadWrite
     _           -> fail "expected permission"
 
-tInterfaceMethod :: Parser ParseEnv (MethodName, Method TypeName)
+tInterfaceMethod :: Parser ParseEnv (MethodName, Method)
 tInterfaceMethod = tList $ do
   n <- tSymbol
   m <- choice [ try tAttr, try tStream ]
@@ -186,25 +193,25 @@ tInterfaceMethod = tList $ do
     tWhiteSpace
     p <- tPermission
     tWhiteSpace
-    tn <- tKnownTypeName
+    tn <- tKnownType
     return (AttrMethod p tn)
   tStream = tList $ do
     tIdentifier "stream"
     tWhiteSpace
     r <- tInteger
     tWhiteSpace
-    tn <- tKnownTypeName
+    tn <- tKnownType
     return (StreamMethod r tn)
 
-tKnownInterfaceName :: Parser ParseEnv InterfaceName
-tKnownInterfaceName  = do
+tKnownInterface :: Parser ParseEnv Interface
+tKnownInterface  = do
   n <- tSymbol
   ie <- getInterfaceEnv
   case lookupInterface n ie of
-    Just _ -> return n
+    Just i -> return i
     Nothing -> fail ("expected a known interface name, got " ++ n)
 
-tInterfaceDecl :: Parser ParseEnv (InterfaceName, InterfaceDescr)
+tInterfaceDecl :: Parser ParseEnv (InterfaceName, Interface)
 tInterfaceDecl = tList $ do
   tIdentifier "def-interface"
   tWhiteSpace
@@ -214,7 +221,7 @@ tInterfaceDecl = tList $ do
   when (not_unique (map fst ms)) $
     fail "expected unique interface method names"
   tWhiteSpace
-  ps <- optionMaybe (tList (many1 tKnownInterfaceName))
+  ps <- optionMaybe (tList (many1 tKnownInterface))
   -- XXX require the ms not shadow names in inherited interfaces
   case ps of
     Just p -> return (n, Interface  p ms)

src/Gidl/Schema.hs

@@ -7,13 +7,13 @@ import Gidl.Types
 import Gidl.Interface
 
 type MsgId = Word32
-data Message = Message String TypeRepr
+data Message = Message String Type
              deriving (Eq, Show)
 data Schema = Schema String [(MsgId, Message)]
             deriving (Eq, Show)
 
 
-producerSchema :: InterfaceRepr -> Schema
+producerSchema :: Interface -> Schema
 producerSchema ir = Schema "Producer" [(mkMsgId m, m) | m <- messages ]
   where
   messages = concatMap mkMessages (interfaceMethods ir)
@@ -23,7 +23,7 @@ producerSchema ir = Schema "Producer" [(mkMsgId m, m) | m <- messages ]
   mkMessages (attrname, (AttrMethod  _ tr)) =
     [ Message (attrname ++ "_val") tr ]
 
-consumerSchema :: InterfaceRepr -> Schema
+consumerSchema :: Interface -> Schema
 consumerSchema ir = Schema "Consumer" [(mkMsgId m, m) | m <- messages ]
   where
   messages = concatMap mkMessages (interfaceMethods ir)
@@ -32,10 +32,10 @@ consumerSchema ir = Schema "Consumer" [(mkMsgId m, m) | m <- messages ]
   mkMessages (attrname, (AttrMethod Write tr)) =
     [ Message (attrname ++ "_set") tr ]
   mkMessages (attrname, (AttrMethod Read _)) =
-    [ Message (attrname ++ "_get") voidTypeRepr ]
+    [ Message (attrname ++ "_get")  (PrimType VoidType) ]
   mkMessages (attrname, (AttrMethod ReadWrite tr)) =
     [ Message (attrname ++ "_set") tr
-    , Message (attrname ++ "_get") voidTypeRepr
+    , Message (attrname ++ "_get") (PrimType VoidType)
     ]
 
 

src/Gidl/Types.hs

@@ -1,23 +1,18 @@
 module Gidl.Types
   ( module Gidl.Types.AST
   , module Gidl.Types.Base
-  , TypeDescr
-  , TypeRepr(..)
   , lookupTypeName
   , insertType
   , typeLeaves
-  , baseType
-  , typeDescrToRepr
   , sizeOf
-  , voidTypeRepr
+  , basePrimType
   ) where
 
 import Data.List (nub)
-import Data.Maybe (fromJust)
 import Gidl.Types.AST
 import Gidl.Types.Base
 
-lookupTypeName :: TypeName -> TypeEnv -> Maybe TypeDescr
+lookupTypeName :: TypeName -> TypeEnv -> Maybe Type
 lookupTypeName tn te =
   case aux te of
     Just a -> Just a
@@ -27,49 +22,26 @@ lookupTypeName tn te =
   where
   aux (TypeEnv e) = lookup tn e
 
-insertType :: TypeName -> TypeDescr -> TypeEnv -> TypeEnv
+insertType :: TypeName -> Type -> TypeEnv -> TypeEnv
 insertType tn t e@(TypeEnv te) = case lookupTypeName tn e of
   Nothing -> TypeEnv ((tn,t):te)
   Just _ -> error ("insertType invariant broken: type " ++ tn ++ " already exists")
 
-typeLeaves :: (Eq t) => Type t -> [t]
-typeLeaves (StructType (Struct s)) = nub (map snd s)
-typeLeaves (NewtypeType (Newtype tn)) = [tn]
-typeLeaves (EnumType _) = []
-typeLeaves (AtomType _) = []
-typeLeaves VoidType = []
+typeLeaves :: Type -> [PrimType]
+typeLeaves (StructType _ s) = nub (map snd s)
+typeLeaves (PrimType (Newtype _ tn)) = [tn]
+typeLeaves _ = []
 
 
-type TypeDescr = Type TypeName
-data TypeRepr = TypeRepr TypeName (Type TypeRepr)
-                deriving (Eq, Show)
-
-voidTypeRepr :: TypeRepr
-voidTypeRepr = TypeRepr "void" VoidType
-
-typeDescrToRepr :: TypeName -> TypeEnv -> TypeRepr
-typeDescrToRepr tn te = TypeRepr tn tr
-  where
-  tr = case fromJust $ lookupTypeName tn te of
-        EnumType e -> EnumType e
-        AtomType a -> AtomType a
-        NewtypeType (Newtype ntn) ->
-          NewtypeType (Newtype (typeDescrToRepr ntn te))
-        StructType (Struct s) ->
-          StructType (Struct [(i, typeDescrToRepr stn te) | (i, stn) <- s])
-        VoidType -> VoidType
-
-
-sizeOf :: TypeRepr -> Integer
-sizeOf (TypeRepr _ (StructType (Struct s))) = sum [ sizeOf tr | (_, tr) <- s ]
-sizeOf (TypeRepr _ (NewtypeType (Newtype tr))) = sizeOf tr
-sizeOf (TypeRepr _ (EnumType (EnumT bs _))) = bitsSize bs
-sizeOf (TypeRepr _ (AtomType (AtomInt bs))) = bitsSize bs
-sizeOf (TypeRepr _ (AtomType (AtomWord bs))) = bitsSize bs
-sizeOf (TypeRepr _ (AtomType AtomFloat)) = 4
-sizeOf (TypeRepr _ (AtomType AtomDouble)) = 8
-sizeOf (TypeRepr _ VoidType) = 0
+sizeOf :: Type -> Integer
+sizeOf (StructType _ s) = sum [ sizeOf (PrimType tr) | (_, tr) <- s ]
+sizeOf (PrimType (Newtype _ tr)) = sizeOf (PrimType tr)
+sizeOf (PrimType (EnumType _ bs _)) = bitsSize bs
+sizeOf (PrimType (AtomType (AtomInt bs))) = bitsSize bs
+sizeOf (PrimType (AtomType (AtomWord bs))) = bitsSize bs
+sizeOf (PrimType (AtomType AtomFloat)) = 4
+sizeOf (PrimType (AtomType AtomDouble)) = 8
+sizeOf (PrimType VoidType) = 0
 
 bitsSize :: Bits -> Integer
 bitsSize Bits8  = 1
@@ -78,6 +50,6 @@ bitsSize Bits32 = 4
 bitsSize Bits64 = 8
 
 -- Reduce a newtype to the innermost concrete type
-baseType :: TypeRepr -> TypeRepr
-baseType (TypeRepr _ (NewtypeType (Newtype t))) = baseType t
-baseType a = a
+basePrimType :: PrimType -> PrimType
+basePrimType (Newtype _ t) = basePrimType t
+basePrimType a = a

src/Gidl/Types/AST.hs

@@ -4,17 +4,20 @@ module Gidl.Types.AST where
 type Identifier = String
 type TypeName = String
 data TypeEnv
-  = TypeEnv [(TypeName, Type TypeName)]
+  = TypeEnv [(TypeName, Type)]
   deriving (Eq, Show)
 
 emptyTypeEnv :: TypeEnv
 emptyTypeEnv = TypeEnv []
 
+data Type
+  = StructType String [(Identifier, PrimType)]
+  | PrimType PrimType
+  deriving (Eq, Show)
 
-data Type t
-  = StructType (Struct t)
-  | NewtypeType (Newtype t)
-  | EnumType EnumT
+data PrimType
+  = Newtype  String PrimType
+  | EnumType String Bits [(Identifier, Integer)]
   | AtomType Atom
   | VoidType
   deriving (Eq, Show)
@@ -24,7 +27,6 @@ data Atom
   | AtomWord Bits
   | AtomFloat
   | AtomDouble
   deriving (Eq, Show)
 
 data Bits
@@ -34,15 +36,3 @@ data Bits
   | Bits64
   deriving (Eq, Show)
 
-data Struct t
-  = Struct [(Identifier, t)]
-  deriving (Eq, Show)
-
-data Newtype t
-  = Newtype t
-  deriving (Eq, Show)
-
-data EnumT
-  = EnumT Bits [(Identifier, Integer)]
-  deriving (Eq, Show)
-

src/Gidl/Types/Base.hs

@@ -16,32 +16,32 @@ module Gidl.Types.Base
 
 import Gidl.Types.AST
 
-uint8_t  :: Type t
-uint8_t  = AtomType (AtomWord Bits8)
-uint16_t :: Type t
-uint16_t = AtomType (AtomWord Bits16)
-uint32_t :: Type t
-uint32_t = AtomType (AtomWord Bits32)
-uint64_t :: Type t
-uint64_t = AtomType (AtomWord Bits64)
-
-sint8_t  :: Type t
-sint8_t  = AtomType (AtomInt  Bits8)
-sint16_t :: Type t
-sint16_t = AtomType (AtomInt  Bits16)
-sint32_t :: Type t
-sint32_t = AtomType (AtomInt  Bits32)
-sint64_t :: Type t
-sint64_t = AtomType (AtomInt  Bits64)
-
-bool_t :: Type t
-bool_t = EnumType (EnumT Bits8 [("false", 0), ("true", 1)])
-
-float_t :: Type t
-float_t = AtomType AtomFloat
-
-double_t :: Type t
-double_t = AtomType AtomDouble
+uint8_t  :: Type
+uint8_t  = PrimType (AtomType (AtomWord Bits8))
+uint16_t :: Type
+uint16_t = PrimType (AtomType (AtomWord Bits16))
+uint32_t :: Type
+uint32_t = PrimType (AtomType (AtomWord Bits32))
+uint64_t :: Type
+uint64_t = PrimType (AtomType (AtomWord Bits64))
+
+sint8_t  :: Type
+sint8_t  = PrimType (AtomType (AtomInt  Bits8))
+sint16_t :: Type
+sint16_t = PrimType (AtomType (AtomInt  Bits16))
+sint32_t :: Type
+sint32_t = PrimType (AtomType (AtomInt  Bits32))
+sint64_t :: Type
+sint64_t = PrimType (AtomType (AtomInt  Bits64))
+
+bool_t :: Type
+bool_t = PrimType (EnumType "bool_t" Bits8 [("false", 0), ("true", 1)])
+
+float_t :: Type
+float_t = PrimType (AtomType AtomFloat)
+
+double_t :: Type
+double_t = PrimType (AtomType AtomDouble)
 
 baseTypeEnv :: TypeEnv
 baseTypeEnv = TypeEnv