gidl: initial commit

.gitignore

@@ -0,0 +1,2 @@
+dist
+cabal.sandbox.config

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

gidl.cabal

@@ -0,0 +1,32 @@
+name:                gidl
+version:             0.1.0.0
+license:             AllRightsReserved
+license-file:        LICENSE
+author:              Pat Hickey
+maintainer:          pat@galois.com
+copyright:           2015 Galois Inc
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Gidl,
+                       Gidl.Parse,
+                       Gidl.Types,
+                       Gidl.Types.AST,
+                       Gidl.Types.Base
+
+  build-depends:       base >=4.7 && <4.8,
+                       parsec,
+                       transformers
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  ghc-options:         -Wall
+
+executable             gidl-test
+  main-is:             Test.hs
+  hs-source-dirs:      tests
+  build-depends:       base >= 4.6,
+                       gidl
+
+  default-language:    Haskell2010
+  ghc-options:         -Wall

src/Gidl.hs

@@ -0,0 +1,2 @@
+module Gidl where
+

src/Gidl/Parse.hs

@@ -0,0 +1,130 @@
+
+module Gidl.Parse where
+
+import Data.Functor.Identity
+import Data.Monoid
+import Control.Monad
+import Text.Parsec.Prim
+import Text.Parsec.Char
+import Text.Parsec.Token
+import Text.Parsec.Combinator
+import Text.Parsec.Language
+import Text.Parsec.Error
+
+import Gidl.Types
+
+type Parser u a = ParsecT String u Identity a
+
+lexer :: GenTokenParser String u Identity
+lexer = makeTokenParser haskellDef
+
+tWhiteSpace :: Parser u ()
+tWhiteSpace = whiteSpace lexer
+
+tInteger :: Parser u Integer
+tInteger = (integer lexer) <?> "integer"
+
+tNatural :: Parser u Integer
+tNatural = do
+  i <- tInteger
+  case i < 0 of
+    True -> fail "expected positive integer"
+    False -> return i
+
+tFloat :: Parser u Double
+tFloat = (float lexer) <?> "floating point number"
+
+tString :: Parser u String
+tString = (stringLiteral lexer) <?> "string"
+
+tSymbol :: Parser u String
+tSymbol = (many1 $ noneOf "()\" \t\n\r") <?> "symbol"
+
+tIdentifier :: String -> Parser u ()
+tIdentifier i = do
+  s <- tSymbol
+  case s == i of
+    True -> return ()
+    False -> fail ("expected identifier " ++ i)
+
+tList :: Parser u a -> Parser u a
+tList c = do
+  tWhiteSpace
+  void $ char '('
+  tWhiteSpace
+  r <- c
+  tWhiteSpace
+  void $ char ')'
+  return r
+  <?> "list"
+
+
+tPair :: Parser u a
+      -> Parser u b
+      -> Parser u (a, b)
+tPair a b = tList $ do
+  ra <- a
+  tWhiteSpace
+  rb <- b
+  return (ra, rb)
+
+tTypeName :: Parser TypeEnv TypeName
+tTypeName = do
+  s <- tSymbol
+  te <- getState
+  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
+  <?> "struct row"
+
+tStructBody :: Parser TypeEnv [(Identifier, TypeName)]
+tStructBody = tList (many1 (tWhiteSpace >> tStructRow))
+  <?> "struct body"
+
+tStructDecl :: Parser TypeEnv (TypeName, Type)
+tStructDecl = tList $ do
+  tIdentifier "def-struct"
+  tWhiteSpace
+  n <- tSymbol
+  b <- tStructBody
+  return (n, StructType (Struct b))
+
+defineType :: (TypeName, Type) -> Parser TypeEnv ()
+defineType (tn, t) = do
+  te <- getState
+  case lookupTypeName tn te of
+    Just _ -> fail ("type named '" ++ tn ++ "' already exists")
+    Nothing -> setState (insertType tn t te)
+
+tNewtypeDecl :: Parser TypeEnv (TypeName, Type)
+tNewtypeDecl = tList $ do
+  tIdentifier "def-newtype"
+  tWhiteSpace
+  n <- tSymbol
+  tWhiteSpace
+  c <- tTypeName
+  return (n, NewtypeType (Newtype c))
+
+tEnumDecl :: Parser TypeEnv (TypeName, Type)
+tEnumDecl = tList $ do
+  tIdentifier "def-enum"
+  tWhiteSpace
+  n <- tSymbol
+  -- XXX specify bit width, optionally
+  vs <- tList $ many1 $ tPair tSymbol tNatural
+  -- XXX check that symbols are unique, numbers are unique, numbers are
+  -- ascending
+  -- XXX make it possible to implicitly assign numbers
+  return (n, EnumType (EnumT Bits32 vs))
+
+tDecls :: Parser TypeEnv TypeEnv
+tDecls = do
+  _ <- many ((choice [try tStructDecl, try tNewtypeDecl, try tEnumDecl]) >>= defineType)
+  getState
+
+parseDecls :: String -> Either ParseError TypeEnv
+parseDecls s = runP tDecls mempty "" s
+

src/Gidl/Types.hs

@@ -0,0 +1,24 @@
+module Gidl.Types
+  ( module Gidl.Types.AST
+  , module Gidl.Types.Base
+  , lookupTypeName
+  , insertType
+  ) where
+import Gidl.Types.AST
+import Gidl.Types.Base
+
+lookupTypeName :: TypeName -> TypeEnv -> Maybe Type
+lookupTypeName tn te =
+  case aux te of
+    Just a -> Just a
+    Nothing -> case aux baseTypeEnv of
+      Just a -> Just a
+      Nothing -> Nothing
+  where
+  aux (TypeEnv e) = lookup tn e
+
+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")
+

src/Gidl/Types/AST.hs

@@ -0,0 +1,51 @@
+
+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 []
+
+data Type
+  = StructType Struct
+  | NewtypeType Newtype
+  | EnumType EnumT
+  | AtomType Atom
+--  | MaybeType Type
+--  | EitherType Type Type
+  deriving (Eq, Show)
+
+data Atom
+  = AtomInt Bits
+  | AtomWord Bits
+  | AtomFloat
+  | AtomDouble
+--  | AtomString Int
+  deriving (Eq, Show)
+
+data Bits
+  = Bits8
+  | Bits16
+  | Bits32
+  | Bits64
+  deriving (Eq, Show)
+
+data Struct
+  = Struct [(Identifier, TypeName)]
+  deriving (Eq, Show)
+
+data Newtype
+  = Newtype TypeName
+  deriving (Eq, Show)
+
+data EnumT
+  = EnumT Bits [(Identifier, Integer)]
+  deriving (Eq, Show)
+

src/Gidl/Types/Base.hs

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

tests/Test.hs

@@ -0,0 +1,49 @@
+module Main where
+
+import Gidl.Types
+import Gidl.Parse
+
+main :: IO ()
+main = test "tests/testtypes.sexpr"
+
+test :: FilePath -> IO ()
+test f = do
+  c <- readFile f
+  print $ parseDecls c
+--- below is just a stash
+
+hb_t :: Type
+hb_t = StructType $ Struct
+          [ ("mode", "mode_t")
+          , ("time", "time_micros_t")
+          ]
+
+mode_t :: Type
+mode_t = StructType $ Struct
+          [ ("armed", "bool_t")
+          , ("controlsource", "controlsource_t" )
+          ]
+
+controlsource_t :: Type
+controlsource_t = EnumType $ EnumT Bits8
+  [ ("manual", 0)
+  , ("auto", 1)
+  ]
+
+time_micros_t :: Type
+time_micros_t = NewtypeType $ Newtype "uint8_t"
+
+typeEnv' :: TypeEnv
+typeEnv' = TypeEnv
+  [ ("hb_t", hb_t)
+  , ("mode_t", mode_t)
+  , ("controlsource_t", controlsource_t)
+  , ("time_micros_t", time_micros_t)
+  ]
+
+
+data Sys = Sys TypeEnv Streams Attrs
+
+data Attrs = Attrs [(String, Either Type Attrs)]
+
+data Streams = Streams [(String, Type)]

tests/testtypes.sexpr

@@ -0,0 +1,7 @@
+(def-newtype time_micros_t sint64_t)
+(def-enum armed_t
+ ((disarmed 0)
+  (armed 1)))
+(def-struct heartbeat_t
+ ((time time_micros_t)
+  (armed armed_t)))