gidl: typeRepr, interface improvements

gidl.cabal

@@ -11,6 +11,7 @@ cabal-version:       >=1.10
 library
   exposed-modules:     Gidl,
                        Gidl.Parse,
+                       Gidl.Interface,
                        Gidl.Interface.AST,
                        Gidl.Types,
                        Gidl.Types.AST,

src/Gidl/Interface.hs

@@ -3,9 +3,14 @@ module Gidl.Interface
   ( module Gidl.Interface.AST
   , lookupInterface
   , insertInterface
+  , interfaceTypes
+  , interfaceParents
   ) where
 
+import Data.List (nub)
+import Data.Maybe (fromJust)
 import Gidl.Interface.AST
+import Gidl.Types
 
 lookupInterface :: InterfaceName -> InterfaceEnv -> Maybe Interface
 lookupInterface iname (InterfaceEnv ie) = lookup iname ie
@@ -15,3 +20,21 @@ 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 -> [InterfaceName]
+interfaceParents (Interface parents _) = parents
+
+interfaceTypes :: InterfaceName -> InterfaceEnv -> TypeEnv -> [TypeName]
+interfaceTypes iname ie te = nub $
+  concatMap aux ms 
+  where
+  (Interface _ ms) = fromJust (lookupInterface iname ie)
+  aux = typeLeaves
+      . fromJust
+      . (\tn -> lookupTypeName tn te)
+      . methodTN
+      . snd
+  methodTN :: Method -> TypeName
+  methodTN (AttrMethod _ tn) = tn
+  methodTN (StreamMethod _ tn) = tn
+
+

src/Gidl/Parse.hs

@@ -107,7 +107,7 @@ tStructBody :: Parser ParseEnv [(Identifier, TypeName)]
 tStructBody = tList (many1 (tWhiteSpace >> tStructRow))
   <?> "struct body"
 
-tStructDecl :: Parser ParseEnv (TypeName, Type)
+tStructDecl :: Parser ParseEnv (TypeName, TypeDescr)
 tStructDecl = tList $ do
   tIdentifier "def-struct"
   tWhiteSpace
@@ -115,7 +115,7 @@ tStructDecl = tList $ do
   b <- tStructBody
   return (n, StructType (Struct b))
 
-defineType :: (TypeName, Type) -> Parser ParseEnv ()
+defineType :: (TypeName, TypeDescr) -> Parser ParseEnv ()
 defineType (tn, t) = do
   te <- getTypeEnv
   case lookupTypeName tn te of
@@ -129,7 +129,7 @@ defineInterface (ina, i) = do
     Just _ -> fail ("interface named '" ++ ina ++ "' already exists")
     Nothing -> setInterfaceEnv (insertInterface ina i ie)
 
-tNewtypeDecl :: Parser ParseEnv (TypeName, Type)
+tNewtypeDecl :: Parser ParseEnv (TypeName, TypeDescr)
 tNewtypeDecl = tList $ do
   tIdentifier "def-newtype"
   tWhiteSpace
@@ -138,7 +138,7 @@ tNewtypeDecl = tList $ do
   c <- tKnownTypeName
   return (n, NewtypeType (Newtype c))
 
-tEnumDecl :: Parser ParseEnv (TypeName, Type)
+tEnumDecl :: Parser ParseEnv (TypeName, TypeDescr)
 tEnumDecl = tList $ do
   tIdentifier "def-enum"
   tWhiteSpace

src/Gidl/Types.hs

@@ -1,13 +1,21 @@
 module Gidl.Types
   ( module Gidl.Types.AST
   , module Gidl.Types.Base
+  , TypeDescr
+  , TypeRepr(..)
   , lookupTypeName
   , insertType
+  , typeLeaves
+  , typeDescrToRepr
+  , sizeOf
   ) where
+
+import Data.List (nub)
+import Data.Maybe (fromJust)
 import Gidl.Types.AST
 import Gidl.Types.Base
 
-lookupTypeName :: TypeName -> TypeEnv -> Maybe Type
+lookupTypeName :: TypeName -> TypeEnv -> Maybe TypeDescr
 lookupTypeName tn te =
   case aux te of
     Just a -> Just a
@@ -17,8 +25,46 @@ lookupTypeName tn te =
   where
   aux (TypeEnv e) = lookup tn e
 
-insertType :: TypeName -> Type -> TypeEnv -> TypeEnv
+insertType :: TypeName -> TypeDescr -> 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 _) = []
+
+
+type TypeDescr = Type TypeName
+data TypeRepr = TypeRepr TypeName (Type TypeRepr)
+                deriving (Eq, Show)
+
+-- invariant: TypeName exists in a well-formed TypeEnv
+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])
+
+
+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
+
+bitsSize :: Bits -> Integer
+bitsSize Bits8  = 1
+bitsSize Bits16 = 2
+bitsSize Bits32 = 4
+bitsSize Bits64 = 8

src/Gidl/Types/AST.hs

@@ -4,15 +4,16 @@ module Gidl.Types.AST where
 type Identifier = String
 type TypeName = String
 data TypeEnv
-  = TypeEnv [(TypeName, Type)]
+  = TypeEnv [(TypeName, Type TypeName)]
   deriving (Eq, Show)
 
 emptyTypeEnv :: TypeEnv
 emptyTypeEnv = TypeEnv []
 
-data Type
-  = StructType Struct
-  | NewtypeType Newtype
+
+data Type t
+  = StructType (Struct t)
+  | NewtypeType (Newtype t)
   | EnumType EnumT
   | AtomType Atom
   deriving (Eq, Show)
@@ -32,12 +33,12 @@ data Bits
   | Bits64
   deriving (Eq, Show)
 
-data Struct
-  = Struct [(Identifier, TypeName)]
+data Struct t
+  = Struct [(Identifier, t)]
   deriving (Eq, Show)
 
-data Newtype
-  = Newtype TypeName
+data Newtype t
+  = Newtype t
   deriving (Eq, Show)
 
 data EnumT

src/Gidl/Types/Base.hs

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

tests/Test.hs

@@ -1,6 +1,8 @@
 module Main where
 
+import Control.Monad
 import Gidl.Types
+import Gidl.Interface
 import Gidl.Parse
 
 main :: IO ()
@@ -11,6 +13,16 @@ test f = do
   c <- readFile f
   case parseDecls c of
     Left e -> print e
-    Right (te, ie) -> do
+    Right (te@(TypeEnv te'), ie@(InterfaceEnv ie')) -> do
       print te
+      putStrLn "---"
+      forM_ te' $ \(tn, t) -> do
+        putStrLn (tn ++ ":")
+        print (typeLeaves t)
+      putStrLn "---"
       print ie
+      putStrLn "---"
+      forM_ ie' $ \(iname, i) -> do
+        putStrLn (iname ++ ":")
+        print (interfaceTypes iname ie te)
+        print (interfaceParents i)

tests/testtypes.sexpr

@@ -44,16 +44,16 @@
 -- to zero). they also implicitly define an attr $(steamname)-stream-rate,
 -- which permits changing the stream rate at runtime.
 
-(def-interface vehicle
+(def-interface vehicle_i
  ((heartbeat (stream 10 heartbeat_t))))
 
 -- Interfaces implement java-style inheritance. No shadowing of inherited method
 -- names permitted.
 
-(def-interface controllable-vehicle
+(def-interface controllable_vehicle_i
   ((current_waypoint (attr read      waypoint_t))
    (next_waypoint    (attr readwrite waypoint_t)))
-  (vehicle)) -- Inherits from interface vehicle
+  (vehicle_i)) -- Inherits from interface vehicle
 
 -- The idea here is that, when negotiating a gidl connection, the client can
 -- specify or negotiate what interface is supported.