Parse basic struct AST

hs-bindgen-patterns/src/HsBindgen/Patterns/Enum/Bitfield.hs

@@ -18,8 +18,8 @@ import Data.Bits
 -- | Single flags
 --
 -- See 'BitfieldEnum' for discussion.
-class IsSingleFlag flag where
-  flagToC :: flag -> CUInt
+class IsSingleFlag hs where
+  flagToC :: hs -> CUInt
 
 -- | Enum that corresponds to a bitfield
 --
@@ -47,18 +47,18 @@ class IsSingleFlag flag where
 -- >   flagToC Flag3 = #const Flag3
 -- >   flagToC Flag4 = #const Flag4
 -- >   flagToC Flag5 = #const Flag5
-newtype BitfieldEnum flag = BitfieldEnum CUInt
+newtype BitfieldEnum hs = BitfieldEnum CUInt
 
 {-------------------------------------------------------------------------------
   API
 -------------------------------------------------------------------------------}
 
 -- | Construct 'BitfieldEnum'
-bitfieldEnum :: IsSingleFlag flag => [flag] -> BitfieldEnum flag
+bitfieldEnum :: IsSingleFlag hs => [hs] -> BitfieldEnum hs
 bitfieldEnum = BitfieldEnum . Foldable.foldl' (.|.) 0 . map flagToC
 
 -- | Check if the given flag is set
-flagIsSet :: IsSingleFlag flag => BitfieldEnum flag -> flag -> Bool
+flagIsSet :: IsSingleFlag hs => BitfieldEnum hs -> hs -> Bool
 flagIsSet (BitfieldEnum i) flag = (i .&. flagToC flag) /= 0
 
 -- | All set flags
@@ -71,6 +71,6 @@ flagIsSet (BitfieldEnum i) flag = (i .&. flagToC flag) /= 0
 -- flags. Their definition has no bearing on the generated C code, and can
 -- simply be derived.
 fromBitfieldEnum ::
-     (IsSingleFlag flag, Enum flag, Bounded flag)
-  => BitfieldEnum flag -> [flag]
+     (IsSingleFlag hs, Enum hs, Bounded hs)
+  => BitfieldEnum hs -> [hs]
 fromBitfieldEnum i = [flag | flag <- [minBound .. maxBound], flagIsSet i flag]

hs-bindgen-patterns/src/HsBindgen/Patterns/Enum/Simple.hs

@@ -8,6 +8,7 @@ module HsBindgen.Patterns.Enum.Simple (
   ) where
 
 import Foreign.C
+import GHC.Show (appPrec1)
 import GHC.Stack
 
 {-------------------------------------------------------------------------------
@@ -17,9 +18,9 @@ import GHC.Stack
 -- | ADTs corresponding to simple enums
 --
 -- See 'SimpleEnum' for discussion
-class IsSimpleEnum a where
+class IsSimpleEnum hs where
   -- | Translate Haskell constructor to C value
-  simpleToC :: a -> CInt
+  simpleToC :: hs -> CInt
 
   -- | Translate C value to haskell constructor
   --
@@ -35,7 +36,7 @@ class IsSimpleEnum a where
   -- > they reside within a specific identifier namespace.
   --
   -- This means that a 'Nothing' value is not necessary an error.
-  simpleFromC :: CInt -> Maybe a
+  simpleFromC :: CInt -> Maybe hs
 
 -- | Simple C enums
 --
@@ -62,24 +63,38 @@ class IsSimpleEnum a where
 -- >   simpleFromC (#const Value3) = Just Value3
 -- >
 -- >   simpleFromC _otherwise = Nothing
-newtype SimpleEnum a = SimpleEnum CInt
+newtype SimpleEnum hs = SimpleEnum CInt
+
+instance (IsSimpleEnum hs, Show hs) => Show (SimpleEnum hs) where
+  showsPrec p x = showParen (p >= appPrec1) $
+      either showC showHS $ fromSimpleEnum x
+    where
+      showC :: CInt -> ShowS
+      showC c =
+            showString "SimpleEnum "
+          . showsPrec appPrec1 c
+
+      showHS :: hs -> ShowS
+      showHS hs =
+             showString "simpleEnum "
+           . showsPrec appPrec1 hs
 
 {-------------------------------------------------------------------------------
   API
 -------------------------------------------------------------------------------}
 
-simpleEnum :: IsSimpleEnum a => a -> SimpleEnum a
+simpleEnum :: IsSimpleEnum hs => hs -> SimpleEnum hs
 simpleEnum = SimpleEnum . simpleToC
 
 -- | Underlying C value
 --
 -- Returns the raw 'CInt' if is out of the range of @a@
-fromSimpleEnum :: IsSimpleEnum a => SimpleEnum a -> Either CInt a
+fromSimpleEnum :: IsSimpleEnum hs => SimpleEnum hs -> Either CInt hs
 fromSimpleEnum (SimpleEnum i) = maybe (Left i) Right $ simpleFromC i
 
 -- | Like 'fromSimpleEnum', but throw an exception if the value is out of range
-unsafeFromSimpleEnum :: (HasCallStack, IsSimpleEnum a) => SimpleEnum a -> a
+unsafeFromSimpleEnum :: (HasCallStack, IsSimpleEnum hs) => SimpleEnum hs -> hs
 unsafeFromSimpleEnum = either (error . err) id . fromSimpleEnum
   where
     err :: CInt -> String
-    err i = "SimpleEnum out of range: " ++ show i
+    err c = "SimpleEnum out of range: " ++ show c

hs-bindgen-patterns/src/HsBindgen/Patterns/SafeForeignPtr.hs

@@ -65,7 +65,7 @@ newSafeForeignPtr ptr finalizer = do
     ref   <- newIORef undefined
 
     let finalizer' :: IO ()
-        finalizer' = writeIORef ref GarbageCollected >> finalizer
+        finalizer' = atomicWriteIORef ref GarbageCollected >> finalizer
 
     foreignPtr <- Concurrent.newForeignPtr ptr finalizer'
     writeIORef ref $ Allocated foreignPtr

hs-bindgen/app/HsBindgen/Cmdline.hs

@@ -3,29 +3,10 @@ module HsBindgen.Cmdline (
   , getCmdline
   ) where
 
+import Data.Default
 import Options.Applicative
 
-import HsBindgen.Preprocessor.Render
-import HsBindgen.Spec qualified as Unresolved
-
-{-------------------------------------------------------------------------------
-  Definition
--------------------------------------------------------------------------------}
-
--- | Command line arguments
---
--- TODO: <https://github.com/well-typed/hs-bindgen/issues/75>
--- We might want to support multiple Haskell modules; in this case, we'll
--- probably want to bundle an 'Unresolved.Spec' with a 'FilePath' (output); we
--- might also want to split 'Unresolved.Spec' into a section that would be
--- common to /all/ modules we want to generate, and then specify that only once
--- on the command line.
-data Cmdline = Cmdline {
-      cmdInput         :: Unresolved.Spec
-    , cmdOutput        :: FilePath
-    , cmdRenderOptions :: RenderOptions
-    }
-  deriving stock (Show)
+import HsBindgen.Lib
 
 {-------------------------------------------------------------------------------
   Top-level
@@ -39,49 +20,141 @@ getCmdline = execParser opts
           header "hs-bindgen - generate Haskell bindings from C headers"
         ]
 
+{-------------------------------------------------------------------------------
+  Definition
+-------------------------------------------------------------------------------}
+
+-- | Command line arguments
+data Cmdline = Cmdline {
+      cmdSpec :: Spec (IO ())
+    }
+
 {-------------------------------------------------------------------------------
   Parser
 -------------------------------------------------------------------------------}
 
 parseCmdline :: Parser Cmdline
 parseCmdline =
     Cmdline
-      <$> parseInput
-      <*> parseOutput
-      <*> parseRenderOptions
+      <$> parseSpec
+
+parseSpec :: Parser (Spec (IO ()))
+parseSpec = subparser $ mconcat [
+      cmd "process" parseCmdProcess $ mconcat [
+          progDesc "Generate Haskell module from C header"
+        ]
+    , cmd "parse" parseCmdParse $ mconcat [
+          progDesc "Parse C header (primarily for debugging hs-bindgen itself)"
+        ]
+    ]
+
+parseCmdProcess :: Parser (Spec (IO ()))
+parseCmdProcess =
+    Preprocess
+      <$> parsePrepareInput
+      <*> parseTranslation
+      <*> parseProcessHsOutput
+
+parseCmdParse :: Parser (Spec (IO ()))
+parseCmdParse =
+    Preprocess
+      <$> parsePrepareInput
+      <*> pure ParseOnly
+      <*> parseProcessCOutput
+
+{-------------------------------------------------------------------------------
+  Prepare input
+-------------------------------------------------------------------------------}
+
+parsePrepareInput :: Parser (PrepareInput CHeader)
+parsePrepareInput =
+    ParseCHeader
+      <$> parseTracer
+      <*> parseClangArgs
+      <*> parseInput
+
+parseTracer :: Parser (Tracer IO String)
+parseTracer = mkTracerIO <$> parseVerbosity
+
+parseVerbosity :: Parser Bool
+parseVerbosity =
+    switch $ mconcat [
+        short 'v'
+      , long "verbose"
+      , help "Verbose output"
+      ]
+
+parseClangArgs :: Parser ClangArgs
+parseClangArgs =
+    many $ strOption $ mconcat [
+        long "clang-option"
+      , help "Pass option to libclang"
+      ]
 
-parseInput :: Parser Unresolved.Spec
+parseInput :: Parser FilePath
 parseInput =
-    Unresolved.Spec
+    strOption $ mconcat [
+        help "Input path to the C header"
+      , metavar "PATH"
+      , long "input"
+      , short 'i'
+      ]
+
+{-------------------------------------------------------------------------------
+  Translation
+-------------------------------------------------------------------------------}
+
+parseTranslation :: Parser (Translation CHeader HsModule)
+parseTranslation =
+    GenModule
+      <$> parseHsModuleOpts
+
+parseHsModuleOpts :: Parser HsModuleOpts
+parseHsModuleOpts =
+    HsModuleOpts
       <$> strOption (mconcat [
-              help "Input path to the C header"
-            , metavar "PATH"
-            , long "input"
-            , short 'i'
-            ])
-      <*> strOption (mconcat [
               help "Name of the generated Haskell module"
             , metavar "NAME"
             , long "module"
             , showDefault
             , value "Generated"
             ])
 
-parseOutput :: Parser FilePath
+{-------------------------------------------------------------------------------
+  Process output
+-------------------------------------------------------------------------------}
+
+parseProcessCOutput :: Parser (ProcessOutput CHeader)
+parseProcessCOutput = pure PrettyC
+
+parseProcessHsOutput :: Parser (ProcessOutput HsModule)
+parseProcessHsOutput =
+    PrettyHs
+      <$> parseHsRenderOpts
+      <*> parseOutput
+
+parseHsRenderOpts :: Parser HsRenderOpts
+parseHsRenderOpts =
+    HsRenderOpts
+      <$> option auto (mconcat [
+              help "Maximum length line"
+            , long "render-line-length"
+            , showDefault
+            , value $ hsLineLength def
+            ])
+
+parseOutput :: Parser (Maybe FilePath)
 parseOutput =
-    strOption $ mconcat [
+    optional $ strOption $ mconcat [
         help "Output path for the Haskell module"
       , metavar "PATH"
       , long "output"
       , short 'o'
       ]
 
-parseRenderOptions :: Parser RenderOptions
-parseRenderOptions =
-    RenderOptions
-      <$> option auto (mconcat [
-              help "Maximum length line"
-            , long "render-line-length"
-            , showDefault
-            , value $ renderLineLength defaultRenderOptions
-            ])
+{-------------------------------------------------------------------------------
+  Internal: optparse-applicative auxiliary
+-------------------------------------------------------------------------------}
+
+cmd :: String -> Parser a -> InfoMod a -> Mod CommandFields a
+cmd name p = command name . info (p <**> helper)

hs-bindgen/app/Main.hs

@@ -1,14 +1,9 @@
-module Main where
+module Main (main) where
 
 import HsBindgen.Cmdline
-import HsBindgen.Preprocessor (generateModule)
-import HsBindgen.Preprocessor.Render (render)
-import HsBindgen.Spec qualified as Spec
+import HsBindgen.Lib
 
 main :: IO ()
 main = do
     cmdline <- getCmdline
-    spec'   <- Spec.resolve (cmdInput cmdline)
-    writeFile (cmdOutput cmdline) $
-      render (cmdRenderOptions cmdline) $
-        generateModule spec'
+    execSpec (cmdSpec cmdline)

hs-bindgen/cbits/clang_wrappers.c

@@ -76,6 +76,14 @@ CXType* wrap_malloc_getPointeeType(CXType* T) {
     return result;
 }
 
+long long wrap_Type_getSizeOf(CXType* T) {
+    return clang_Type_getSizeOf(*T);
+}
+
+long long wrap_Type_getAlignOf(CXType* T) {
+    return clang_Type_getAlignOf(*T);
+}
+
 /**
  * Mapping between cursors and source code
  */

hs-bindgen/cbits/clang_wrappers.h

@@ -40,6 +40,9 @@ CXType* wrap_malloc_getCursorType(CXCursor* C);
 CXString* wrap_malloc_getTypeKindSpelling(enum CXTypeKind K);
 CXString* wrap_malloc_getTypeSpelling(CXType* CT);
 CXType* wrap_malloc_getPointeeType(CXType* T);
+long long wrap_Type_getSizeOf(CXType* T);
+long long wrap_Type_getAlignOf(CXType* T);
+
 
 /**
  * Mapping between cursors and source code

hs-bindgen/clang-tutorial/Main.hs

@@ -6,8 +6,8 @@ module Main (main) where
 import Control.Monad
 import System.Environment
 
-import HsBindgen.Clang.LowLevel
-import HsBindgen.Clang.Util
+import HsBindgen.C.Clang
+import HsBindgen.C.Clang.Util
 import HsBindgen.Patterns
 
 {-------------------------------------------------------------------------------
@@ -20,7 +20,7 @@ tutorial fp = do
     -- Obtain a cursor at the root of the translation unit
     --
 
-    index  <- clang_createIndex 0 0
+    index  <- clang_createIndex DontDisplayDiagnostics
     unit   <- clang_parseTranslationUnit
                 index
                 fp

hs-bindgen/examples/simple_structs.h

@@ -0,0 +1,12 @@
+// struct without typedef
+struct S1 {
+    int a;
+    char b;
+};
+
+// struct with typedef
+typedef struct S2 {
+    char a; 
+    int b;
+    float c;
+} S2;