mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
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`.
238 lines
7.4 KiB
Haskell
238 lines
7.4 KiB
Haskell
{-# LANGUAGE DeriveDataTypeable #-}
|
|
{-# OPTIONS_GHC -fno-cse #-}
|
|
|
|
module Main where
|
|
|
|
import Data.Char (isUpper, toLower)
|
|
import Obj
|
|
import Options.Applicative hiding ((<|>))
|
|
import Path
|
|
import Reify
|
|
import Text.Parsec ((<|>))
|
|
import qualified Text.Parsec as Parsec
|
|
import Types
|
|
import Util
|
|
|
|
data Args = Args
|
|
{ prefixToRemove :: String,
|
|
kebabCase :: Bool,
|
|
emitCName :: Bool,
|
|
sourcePath :: String
|
|
}
|
|
deriving (Show)
|
|
|
|
parseArgs :: Parser Args
|
|
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
|
|
parsedArgs <- execParser $ Options.Applicative.info (parseArgs <**> helper) fullDesc
|
|
let path = sourcePath parsedArgs
|
|
if path /= ""
|
|
then do
|
|
source <- slurp path
|
|
putStrLn
|
|
( joinWith
|
|
"\n"
|
|
( map
|
|
pretty
|
|
( parseHeaderFile
|
|
path
|
|
source
|
|
(prefixToRemove parsedArgs)
|
|
(kebabCase parsedArgs)
|
|
(emitCName parsedArgs)
|
|
)
|
|
)
|
|
)
|
|
else print parsedArgs
|
|
|
|
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
|
|
where
|
|
cSyntax :: Parsec.Parsec String () [[XObj]]
|
|
cSyntax = Parsec.sepBy line (Parsec.char '\n')
|
|
line :: Parsec.Parsec String () [XObj]
|
|
line =
|
|
Parsec.try prefixedFunctionPrototype
|
|
<|> Parsec.try functionPrototype
|
|
<|> Parsec.try define
|
|
<|> discarded
|
|
define :: Parsec.Parsec String () [XObj]
|
|
define = do
|
|
Parsec.many spaceOrTab
|
|
Parsec.string "#define"
|
|
Parsec.many spaceOrTab
|
|
name <- Parsec.many1 identifierChar
|
|
argList <- Parsec.optionMaybe argList
|
|
Parsec.many spaceOrTab
|
|
_ <- defineBody
|
|
Parsec.many spaceOrTab
|
|
-- OBS! Never kebab
|
|
case argList of
|
|
Nothing ->
|
|
let tyXObj =
|
|
XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
|
|
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 cName)
|
|
where
|
|
argList = do
|
|
_ <- Parsec.char '('
|
|
args <-
|
|
Parsec.sepBy
|
|
( Parsec.many spaceOrTab
|
|
>> Parsec.many1 identifierChar
|
|
)
|
|
(Parsec.char ',')
|
|
_ <- Parsec.char ')'
|
|
pure args
|
|
genTypes 0 = []
|
|
genTypes n = (("a" ++ show n), 0) : genTypes (n - 1)
|
|
defineBody :: Parsec.Parsec String () ()
|
|
defineBody = do
|
|
s <- Parsec.many (Parsec.noneOf "\\\n")
|
|
ending <- Parsec.optionMaybe (Parsec.string "\\\n")
|
|
case ending of
|
|
Nothing ->
|
|
do
|
|
c <- Parsec.optionMaybe (Parsec.noneOf "\n")
|
|
case c of
|
|
Just _ -> defineBody
|
|
Nothing -> pure ()
|
|
Just _ -> defineBody
|
|
prefixedFunctionPrototype :: Parsec.Parsec String () [XObj]
|
|
prefixedFunctionPrototype = do
|
|
Parsec.many spaceOrTab
|
|
_ <- Parsec.many1 identifierChar
|
|
functionPrototype
|
|
functionPrototype :: Parsec.Parsec String () [XObj]
|
|
functionPrototype = do
|
|
Parsec.many spaceOrTab
|
|
returnTypeString <- Parsec.many1 identifierChar
|
|
stars1 <- stars
|
|
Parsec.many1 spaceOrTab
|
|
stars2 <- stars
|
|
name <- Parsec.many1 identifierChar
|
|
Parsec.many spaceOrTab
|
|
argTypeStrings <-
|
|
Parsec.try voidArg
|
|
<|> argList
|
|
Parsec.many spaceOrTab
|
|
Parsec.char ';'
|
|
Parsec.many (Parsec.noneOf "\n")
|
|
let tyXObj = toFnTypeXObj argTypeStrings (returnTypeString, length stars1 + length stars2)
|
|
pure (createRegisterForm name tyXObj prefix kebab cName)
|
|
voidArg :: Parsec.Parsec String () [(String, Int)]
|
|
voidArg = do
|
|
_ <- Parsec.string "(void)"
|
|
pure []
|
|
argList :: Parsec.Parsec String () [(String, Int)]
|
|
argList = do
|
|
Parsec.char '('
|
|
args <- Parsec.sepBy arg (Parsec.char ',')
|
|
Parsec.char ')'
|
|
pure args
|
|
arg :: Parsec.Parsec String () (String, Int)
|
|
arg = do
|
|
Parsec.many spaceOrTab
|
|
_ <- Parsec.option "" $ do
|
|
Parsec.string "const"
|
|
Parsec.many spaceOrTab
|
|
argTypeAsString <- Parsec.many1 identifierChar
|
|
stars1 <- stars
|
|
Parsec.many1 spaceOrTab
|
|
stars2 <- stars
|
|
_ <- Parsec.many1 identifierChar
|
|
Parsec.many spaceOrTab
|
|
pure (argTypeAsString, length stars1 + length stars2)
|
|
stars :: Parsec.Parsec String () String
|
|
stars = Parsec.many (Parsec.char '*')
|
|
spaceOrTab :: Parsec.Parsec String () Char
|
|
spaceOrTab = Parsec.choice [Parsec.char ' ', Parsec.char '\t']
|
|
discarded :: Parsec.Parsec String () [XObj]
|
|
discarded = do
|
|
discardedLine <- Parsec.many (Parsec.noneOf "\n")
|
|
pure []
|
|
|
|
--pure [(XObj (Str ("DISCARDED: " ++ discardedLine)) Nothing Nothing)]
|
|
|
|
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)
|
|
emitName = name
|
|
in [ XObj
|
|
( Lst
|
|
( [ (XObj (Sym (SymPath [] "register") Symbol) Nothing Nothing),
|
|
(XObj (Sym (SymPath [] carpName) Symbol) Nothing Nothing),
|
|
tyXObj
|
|
]
|
|
++ if (prefix /= "") || kebab || cName
|
|
then [(XObj (Str emitName) Nothing Nothing)]
|
|
else []
|
|
)
|
|
)
|
|
Nothing
|
|
Nothing
|
|
]
|
|
|
|
toFnTypeXObj :: [(String, Int)] -> (String, Int) -> XObj
|
|
toFnTypeXObj argTypeStrings returnTypeString =
|
|
( XObj
|
|
( Lst
|
|
[ (XObj (Sym (SymPath [] "λ") Symbol) Nothing Nothing),
|
|
(XObj (Arr (map (reify . cTypeToCarpType) argTypeStrings)) Nothing Nothing),
|
|
(XObj (Sym (SymPath [] (show (cTypeToCarpType returnTypeString))) Symbol) Nothing Nothing)
|
|
]
|
|
)
|
|
Nothing
|
|
Nothing
|
|
)
|
|
|
|
toTypeXObj :: (String, Int) -> XObj
|
|
toTypeXObj typeString =
|
|
(XObj (Sym (SymPath [] (show (cTypeToCarpType typeString))) Symbol) Nothing Nothing)
|
|
|
|
cTypeToCarpType :: (String, Int) -> Ty
|
|
cTypeToCarpType ("char", 0) = CCharTy
|
|
cTypeToCarpType ("int", 0) = IntTy
|
|
cTypeToCarpType ("bool", 0) = BoolTy
|
|
cTypeToCarpType ("long", 0) = LongTy
|
|
cTypeToCarpType ("double", 0) = DoubleTy
|
|
cTypeToCarpType ("float", 0) = FloatTy
|
|
cTypeToCarpType ("void", 0) = UnitTy
|
|
cTypeToCarpType (s, 0) = (StructTy (ConcreteNameTy (SymPath [] s)) [])
|
|
cTypeToCarpType (x, stars) = (PointerTy (cTypeToCarpType (x, stars - 1)))
|
|
|
|
identifierChar :: Parsec.Parsec String () Char
|
|
identifierChar = Parsec.choice [Parsec.letter, Parsec.digit, Parsec.char '_']
|
|
|
|
removePrefix :: String -> String -> String
|
|
removePrefix prefix s =
|
|
case Parsec.runParser match () "" s of
|
|
Left err -> s
|
|
Right ok -> ok
|
|
where
|
|
match =
|
|
do
|
|
_ <- Parsec.string prefix
|
|
Parsec.many1 identifierChar
|
|
|
|
lowerFirst :: String -> String
|
|
lowerFirst (c : cs) = toLower c : cs
|
|
|
|
toKebab :: String -> String
|
|
toKebab [] = []
|
|
toKebab (c : cs) = (if isUpper c then ['-', toLower c] else [c]) ++ toKebab cs
|