feat: Adds flag to always output C id with headerparse (#1353)

Adds -c|--emitcname flag to headerparse to always emit the C identifier
in `register` definitions (useful when the register will be in a
module).

Fixes a bug where the kebab case flag would not output C identifiers
making the emitted C identifiers not match with the ones in the headers.

Adds docs entry about headerparse in CInterop doc.

Makes headerparse emit `CChar` instead of `Char` when encountering a
signature containing `char`.

docs/CInterop.md

@@ -16,6 +16,7 @@ This is an extension of what is covered in the [Language Guide](./LanguageGuide.
   - [`preproc`](#unsafe-preproc)
   - [Registering Types](#register-types)
 - [Callbacks](#callbacks)
+- [Headerparse](#headerparse)
 
 
 ## How Carp generates identifiers
@@ -558,3 +559,39 @@ it is the responsibility of the caller to ensure the operation is safe. It is
 also important to ensure the lifetime of the `Ptr` doesn't not exceed the
 lifetime of the function/env it represents.
 
+## Headerparse
+
+`headerparse` is a Haskell script to aid in writing C bindings by parsing a C
+header and generating `register` and `register-type` for you. It resides in the
+`./headersparse` folder in Carp source repo and can be used in the following
+way:
+
+```sh
+stack runhaskell ./headerparse/Main.hs -- ../path/to/c/header.h
+```
+
+The script accepts the following flags:
+
+* `[-p|--prefixtoremove thePrefix]` Removes a prefix from the C identifiers
+* `[-f|--kebabcase]` Converts identifiers to kebab-case
+* `[-c|--emitcname]` Always emit the C identifier name after the binding
+
+### Example
+
+Invoking the script on this C header:
+
+```sh
+stack runhaskell ./headerparse/Main.hs -- -p "MyModule_" -f ../path/to/aheader.h
+```
+
+```c
+// aheader.h
+bool MyModule_runThisFile(const char *file);
+```
+
+Will output the following:
+
+```clojure
+(register run-this-file (λ [(Ptr CChar)] Bool) "MyModule_runThisFile")
+```
+

headerparse/Main.hs

@@ -16,6 +16,7 @@ import Util
 data Args = Args
   { prefixToRemove :: String,
     kebabCase :: Bool,
+    emitCName :: Bool,
     sourcePath :: String
   }
   deriving (Show)
@@ -25,6 +26,7 @@ parseArgs =
   Args
     <$> strOption (long "prefixtoremove" <> short 'p' <> metavar "ITEM" <> value "")
     <*> switch (long "kebabcase" <> short 'f')
+    <*> switch (long "emitcname" <> short 'c')
     <*> argument str (metavar "FILE")
 
 main = do
@@ -43,13 +45,14 @@ main = do
                     source
                     (prefixToRemove parsedArgs)
                     (kebabCase parsedArgs)
+                    (emitCName parsedArgs)
                 )
             )
         )
     else print parsedArgs
 
-parseHeaderFile :: FilePath -> String -> String -> Bool -> [XObj]
-parseHeaderFile path src prefix kebab =
+parseHeaderFile :: FilePath -> String -> String -> Bool -> Bool -> [XObj]
+parseHeaderFile path src prefix kebab cName =
   case Parsec.runParser cSyntax () path src of
     Left err -> error (show err)
     Right ok -> concat ok
@@ -77,11 +80,11 @@ parseHeaderFile path src prefix kebab =
         Nothing ->
           let tyXObj =
                 XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
-           in pure (createRegisterForm name tyXObj prefix False)
+           in pure (createRegisterForm name tyXObj prefix False cName)
         Just args ->
           let argsTy = genTypes (length args)
               tyXObj = toFnTypeXObj argsTy ("a", 0)
-           in pure (createRegisterForm name tyXObj prefix False)
+           in pure (createRegisterForm name tyXObj prefix False cName)
       where
         argList = do
           _ <- Parsec.char '('
@@ -128,7 +131,7 @@ parseHeaderFile path src prefix kebab =
       Parsec.char ';'
       Parsec.many (Parsec.noneOf "\n")
       let tyXObj = toFnTypeXObj argTypeStrings (returnTypeString, length stars1 + length stars2)
-      pure (createRegisterForm name tyXObj prefix kebab)
+      pure (createRegisterForm name tyXObj prefix kebab cName)
     voidArg :: Parsec.Parsec String () [(String, Int)]
     voidArg = do
       _ <- Parsec.string "(void)"
@@ -163,8 +166,8 @@ parseHeaderFile path src prefix kebab =
 
 --pure [(XObj (Str ("DISCARDED: " ++ discardedLine)) Nothing Nothing)]
 
-createRegisterForm :: String -> XObj -> String -> Bool -> [XObj]
-createRegisterForm name tyXObj prefix kebab =
+createRegisterForm :: String -> XObj -> String -> Bool -> Bool -> [XObj]
+createRegisterForm name tyXObj prefix kebab cName =
   let carpName =
         (if kebab then (toKebab . lowerFirst) else id)
           (if prefix == "" then name else removePrefix prefix name)
@@ -175,9 +178,9 @@ createRegisterForm name tyXObj prefix kebab =
                   (XObj (Sym (SymPath [] carpName) Symbol) Nothing Nothing),
                   tyXObj
                 ]
-                  ++ if prefix == ""
-                    then []
-                    else [(XObj (Str emitName) Nothing Nothing)]
+                  ++ if (prefix /= "") || kebab || cName
+                    then [(XObj (Str emitName) Nothing Nothing)]
+                    else []
               )
           )
           Nothing
@@ -202,7 +205,7 @@ toTypeXObj typeString =
   (XObj (Sym (SymPath [] (show (cTypeToCarpType typeString))) Symbol) Nothing Nothing)
 
 cTypeToCarpType :: (String, Int) -> Ty
-cTypeToCarpType ("char", 0) = CharTy
+cTypeToCarpType ("char", 0) = CCharTy
 cTypeToCarpType ("int", 0) = IntTy
 cTypeToCarpType ("bool", 0) = BoolTy
 cTypeToCarpType ("long", 0) = LongTy

src/Types.hs

@@ -53,6 +53,7 @@ data Ty
   | StringTy
   | PatternTy
   | CharTy
+  | CCharTy
   | FuncTy [Ty] Ty Ty -- In order of appearance: (1) Argument types, (2) Return type, (3) Lifetime
   | VarTy String
   | UnitTy
@@ -171,6 +172,7 @@ instance Show Ty where
   show StringTy = "String"
   show PatternTy = "Pattern"
   show CharTy = "Char"
+  show CCharTy = "CChar"
   show (FuncTy argTys retTy StaticLifetimeTy) = "(" ++ fnOrLambda ++ " [" ++ joinWithComma (map show argTys) ++ "] " ++ show retTy ++ ")"
   show (FuncTy argTys retTy lt) = "(" ++ fnOrLambda ++ " [" ++ joinWithComma (map show argTys) ++ "] " ++ show retTy ++ " " ++ show lt ++ ")"
   show (VarTy t) = t

src/TypesToC.hs

@@ -39,6 +39,7 @@ tyToCManglePtr _ ty = f ty
     f StringTy = "String"
     f PatternTy = "Pattern"
     f CharTy = "Char"
+    f CCharTy = "CChar"
     f UnitTy = "void"
     f (VarTy x) = x
     f (FuncTy argTys retTy _) = "Fn__" ++ joinWithUnderscore (map (tyToCManglePtr True) argTys) ++ "_" ++ tyToCManglePtr True retTy