we can now parse the interfaces in the test file

gidl.cabal

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

src/Gidl/Interface.hs

@@ -0,0 +1,17 @@
+
+module Gidl.Interface
+  ( module Gidl.Interface.AST
+  , lookupInterface
+  , insertInterface
+  ) where
+
+import Gidl.Interface.AST
+
+lookupInterface :: InterfaceName -> InterfaceEnv -> Maybe Interface
+lookupInterface iname (InterfaceEnv ie) = lookup iname ie
+
+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")
+

src/Gidl/Interface/AST.hs

@@ -0,0 +1,31 @@
+
+module Gidl.Interface.AST where
+
+import Gidl.Types.AST
+
+data InterfaceEnv
+  = InterfaceEnv [(InterfaceName, Interface)]
+  deriving (Eq, Show)
+
+emptyInterfaceEnv :: InterfaceEnv
+emptyInterfaceEnv = InterfaceEnv []
+
+type InterfaceName = String
+type MethodName = String
+
+data Interface
+  = Interface [InterfaceName] [(MethodName, Method)]
+  deriving (Eq, Show)
+
+data Method
+  = AttrMethod Perm TypeName
+  | StreamMethod Integer TypeName
+  deriving (Eq, Show)
+
+data Perm
+  = Read
+  | Write
+  | ReadWrite
+  deriving (Eq, Show)
+
+

src/Gidl/Parse.hs

@@ -2,7 +2,6 @@
 module Gidl.Parse where
 
 import Data.Functor.Identity
-import Data.Monoid
 import Control.Monad
 import Text.Parsec.Prim
 import Text.Parsec.Char
@@ -12,8 +11,31 @@ import Text.Parsec.Language
 import Text.Parsec.Error
 
 import Gidl.Types
+import Gidl.Interface
 
 type Parser u a = ParsecT String u Identity a
+type ParseEnv = (TypeEnv, InterfaceEnv)
+
+emptyParseEnv :: ParseEnv
+emptyParseEnv = (emptyTypeEnv, emptyInterfaceEnv)
+
+getTypeEnv :: Parser ParseEnv TypeEnv
+getTypeEnv = fmap fst getState
+
+getInterfaceEnv :: Parser ParseEnv InterfaceEnv
+getInterfaceEnv = fmap snd getState
+
+setTypeEnv :: TypeEnv -> Parser ParseEnv ()
+setTypeEnv te = do
+  (_, ie) <- getState
+  setState (te, ie)
+
+setInterfaceEnv :: InterfaceEnv -> Parser ParseEnv ()
+setInterfaceEnv ie = do
+  (te, _) <- getState
+  setState (te, ie)
+
+---
 
 lexer :: GenTokenParser String u Identity
 lexer = makeTokenParser haskellDef
@@ -68,23 +90,23 @@ tPair a b = tList $ do
   rb <- b
   return (ra, rb)
 
-tTypeName :: Parser TypeEnv TypeName
-tTypeName = do
+tKnownTypeName :: Parser ParseEnv TypeName
+tKnownTypeName = do
   s <- tSymbol
-  te <- getState
+  te <- getTypeEnv
   case lookupTypeName s te of
     Just _ -> return s
     Nothing -> fail ("expected a known type name, got " ++ s)
 
-tStructRow :: Parser TypeEnv (Identifier, TypeName)
-tStructRow = tPair tSymbol tTypeName
+tStructRow :: Parser ParseEnv (Identifier, TypeName)
+tStructRow = tPair tSymbol tKnownTypeName
   <?> "struct row"
 
-tStructBody :: Parser TypeEnv [(Identifier, TypeName)]
+tStructBody :: Parser ParseEnv [(Identifier, TypeName)]
 tStructBody = tList (many1 (tWhiteSpace >> tStructRow))
   <?> "struct body"
 
-tStructDecl :: Parser TypeEnv (TypeName, Type)
+tStructDecl :: Parser ParseEnv (TypeName, Type)
 tStructDecl = tList $ do
   tIdentifier "def-struct"
   tWhiteSpace
@@ -92,23 +114,30 @@ tStructDecl = tList $ do
   b <- tStructBody
   return (n, StructType (Struct b))
 
-defineType :: (TypeName, Type) -> Parser TypeEnv ()
+defineType :: (TypeName, Type) -> Parser ParseEnv ()
 defineType (tn, t) = do
-  te <- getState
+  te <- getTypeEnv
   case lookupTypeName tn te of
     Just _ -> fail ("type named '" ++ tn ++ "' already exists")
-    Nothing -> setState (insertType tn t te)
+    Nothing -> setTypeEnv (insertType tn t te)
 
-tNewtypeDecl :: Parser TypeEnv (TypeName, Type)
+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, Type)
 tNewtypeDecl = tList $ do
   tIdentifier "def-newtype"
   tWhiteSpace
   n <- tSymbol
   tWhiteSpace
-  c <- tTypeName
+  c <- tKnownTypeName
   return (n, NewtypeType (Newtype c))
 
-tEnumDecl :: Parser TypeEnv (TypeName, Type)
+tEnumDecl :: Parser ParseEnv (TypeName, Type)
 tEnumDecl = tList $ do
   tIdentifier "def-enum"
   tWhiteSpace
@@ -120,11 +149,72 @@ tEnumDecl = tList $ do
   -- XXX make it possible to implicitly assign numbers
   return (n, EnumType (EnumT Bits32 vs))
 
-tDecls :: Parser TypeEnv TypeEnv
+tPermission :: Parser a Perm
+tPermission = do
+  s <- tSymbol
+  case s of
+    "read"      -> return Read
+    "r"         -> return Read
+    "write"     -> return Write
+    "w"         -> return Write
+    "readwrite" -> return ReadWrite
+    "rw"        -> return ReadWrite
+    _           -> fail "expected permission"
+
+tInterfaceMethod :: Parser ParseEnv (MethodName, Method)
+tInterfaceMethod = tList $ do
+  n <- tSymbol
+  m <- choice [ try tAttr, try tStream ]
+  return (n, m)
+  where
+  tAttr = tList $ do
+    tIdentifier "attr"
+    tWhiteSpace
+    p <- tPermission
+    tWhiteSpace
+    tn <- tKnownTypeName
+    return (AttrMethod p tn)
+  tStream = tList $ do
+    tIdentifier "stream"
+    tWhiteSpace
+    r <- tInteger
+    tWhiteSpace
+    tn <- tKnownTypeName
+    return (StreamMethod r tn)
+
+tKnownInterfaceName :: Parser ParseEnv InterfaceName
+tKnownInterfaceName  = do
+  n <- tSymbol
+  ie <- getInterfaceEnv
+  case lookupInterface n ie of
+    Just _ -> return n
+    Nothing -> fail ("expected a known interface name, got " ++ n)
+
+tInterfaceDecl :: Parser ParseEnv (InterfaceName, Interface)
+tInterfaceDecl = tList $ do
+  tIdentifier "def-interface"
+  tWhiteSpace
+  n <- tSymbol
+  tWhiteSpace
+  ms <- tList (many1 tInterfaceMethod)
+  -- XXX require the names to be unique
+  tWhiteSpace
+  ps <- optionMaybe (tList (many1 tKnownInterfaceName))
+  -- XXX require the ms not shadow names in inherited interfaces
+  case ps of
+    Just p -> return (n, Interface  p ms)
+    Nothing -> return (n, Interface [] ms)
+
+tDecls :: Parser ParseEnv ParseEnv
 tDecls = do
-  _ <- many ((choice [try tStructDecl, try tNewtypeDecl, try tEnumDecl]) >>= defineType)
+  _ <- many (choice [ try tStructDecl    >>= defineType
+                    , try tNewtypeDecl   >>= defineType
+                    , try tEnumDecl      >>= defineType
+                    , try tInterfaceDecl >>= defineInterface
+                    ])
+  tWhiteSpace >> eof
   getState
 
-parseDecls :: String -> Either ParseError TypeEnv
-parseDecls s = runP tDecls mempty "" s
+parseDecls :: String -> Either ParseError ParseEnv
+parseDecls s = runP tDecls emptyParseEnv "" s
 

src/Gidl/Types/AST.hs

@@ -1,17 +1,14 @@
 
 module Gidl.Types.AST where
 
-import Data.Monoid
-
 type Identifier = String
 type TypeName = String
 data TypeEnv
   = TypeEnv [(TypeName, Type)]
   deriving (Eq, Show)
 
-instance Monoid TypeEnv where
-  (TypeEnv a) `mappend` (TypeEnv b) = TypeEnv (a ++ b)
-  mempty = TypeEnv []
+emptyTypeEnv :: TypeEnv
+emptyTypeEnv = TypeEnv []
 
 data Type
   = StructType Struct

tests/testtypes.sexpr

@@ -11,10 +11,6 @@
  ((time time_micros_t)
   (armed armed_t)))
 
-
 (def-newtype lat_t sint32_t)
 (def-newtype lon_t sint32_t)
 
@@ -32,6 +28,8 @@
   (lon lon_t)
   (alt meters_t)))
 
+(def-newtype waypoint_t coordinate_t)
+
 -- Todo: the following interface syntax and semantics are a strawman.
 -- Interfaces have methods that are either streams or attrs.
 -- attrs take a parameter for access control.