mirror of
https://github.com/carp-lang/Carp.git
synced 2024-10-11 20:49:05 +03:00
168 lines
6.9 KiB
Haskell
168 lines
6.9 KiB
Haskell
{-# LANGUAGE DeriveDataTypeable #-}
|
|
{-# OPTIONS_GHC -fno-cse #-}
|
|
|
|
module Main where
|
|
|
|
import System.Console.CmdArgs
|
|
import Text.Parsec ((<|>))
|
|
import qualified Text.Parsec as Parsec
|
|
import Data.Char (toLower, isUpper)
|
|
import Util
|
|
import Types
|
|
import Obj
|
|
|
|
data Args = Args { sourcePath :: String
|
|
, prefixToRemove :: String
|
|
, kebabCase :: Bool
|
|
} deriving (Show, Data, Typeable)
|
|
|
|
main = do parsedArgs <- cmdArgs (Args { sourcePath = def &= argPos 0
|
|
, prefixToRemove = def
|
|
, kebabCase = False
|
|
}
|
|
&= summary "Carp Header Parse 0.0.1")
|
|
let path = sourcePath parsedArgs
|
|
if path /= ""
|
|
then do source <- readFile path
|
|
putStrLn (joinWith "\n" (map pretty (parseHeaderFile path source
|
|
(prefixToRemove parsedArgs)
|
|
(kebabCase parsedArgs))))
|
|
else print parsedArgs
|
|
|
|
parseHeaderFile :: FilePath -> String -> String -> Bool -> [XObj]
|
|
parseHeaderFile path src prefix kebab =
|
|
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
|
|
Parsec.many spaceOrTab
|
|
number <- Parsec.many1 identifierChar
|
|
Parsec.many spaceOrTab
|
|
let tyXObj =
|
|
--toTypeXObj ("a", 0)
|
|
XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
|
|
return (createRegisterForm name tyXObj prefix False) -- OBS! Never kebab
|
|
|
|
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 spaceOrTab
|
|
let tyXObj = toFnTypeXObj argTypeStrings (returnTypeString, length stars1 + length stars2)
|
|
return (createRegisterForm name tyXObj prefix kebab)
|
|
|
|
voidArg :: Parsec.Parsec String () [(String, Int)]
|
|
voidArg = do _ <- Parsec.string "(void)"
|
|
return []
|
|
|
|
argList :: Parsec.Parsec String () [(String, Int)]
|
|
argList = do Parsec.char '('
|
|
args <- Parsec.sepBy arg (Parsec.char ',')
|
|
Parsec.char ')'
|
|
return 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
|
|
return (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")
|
|
return []
|
|
--return [(XObj (Str ("DISCARDED: " ++ discardedLine)) Nothing Nothing)]
|
|
|
|
createRegisterForm :: String -> XObj -> String -> Bool -> [XObj]
|
|
createRegisterForm name tyXObj prefix kebab =
|
|
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 == ""
|
|
then []
|
|
else [(XObj (Str emitName) Nothing Nothing)]
|
|
)) Nothing Nothing]
|
|
|
|
toFnTypeXObj :: [(String, Int)] -> (String, Int) -> XObj
|
|
toFnTypeXObj argTypeStrings returnTypeString =
|
|
(XObj (Lst [ (XObj (Sym (SymPath [] "λ") Symbol) Nothing Nothing)
|
|
, (XObj (Arr (map (tyToXObj . 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) = CharTy
|
|
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 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
|