#!/bin/runhaskell {-# LANGUAGE FlexibleContexts #-} import Control.Monad import Text.Parsec import Text.Parsec.String import Data.List import System.Environment import Data.Char import Text.Printf import Debug.Trace data ArgumentType = Normal String | Self String deriving Show data Argument = Argument { argumentType :: ArgumentType, argumentName :: String, realArgumentType :: String } deriving Show data FunctionName = FunctionName { realName :: String, className :: String, argument :: Argument } deriving Show ppArgument :: String -> Argument -> String ppArgument seperator argument = (getArgumentType . argumentType $ argument) ++ seperator ++ (argumentName argument) ppCPPArgument seperator argument = (realArgumentType $ argument) ++ seperator ++ (argumentName argument) exportMacro = "FL_EXPORT_C" getArgumentType (Normal s) = s getArgumentType (Self s) = s isSelf (Self _) = True isSelf _ = False needsCasting argument = not ((isSelf $ argumentType argument) || ((getArgumentType $ argumentType argument) == realArgumentType argument)) cast argument variable = "(static_cast<" ++ realArgumentType argument ++ "*>" ++ "(" ++ variable ++ "))" backCast argument variable = "(" ++ (getArgumentType . argumentType $ argument) ++ ")" ++ " " ++ variable castIfNecessary argument | (isSelf $ argumentType argument) = argumentName argument castIfNecessary argument | ((getArgumentType $ argumentType argument) == (realArgumentType argument)) = argumentName argument castIfNecessary argument = "(static_cast<" ++ realArgumentType argument ++ "*>" ++ "(" ++ argumentName argument ++ "))" getSelfArgument args = case filter (\arg -> case (argumentType arg) of (Self _) -> True _ -> False) args of (x:xs) -> Just(argumentName x) [] -> Nothing outputDefaultImplementation (CPP (fn,args)) = let header = exportMacro ++ "(" ++ ppArgument "," (argument fn) ++ ")" ++ "(" ++ intercalate "," (map (ppArgument " ") args) ++ ")" return = if ("void" == (getArgumentType . argumentType . argument $ fn)) then "" else "return" body = case ((argumentType . argument $ fn), getSelfArgument args) of (Normal t, Just self) -> (printf "{\n %s (static_cast<%s*>(%s))->%s(%s);\n}" return (className fn) self (realName fn) (intercalate "," (map castIfNecessary (tail args)))) (Normal t, Nothing) -> (printf "{\n %s %s::%s(%s);\n}" return (className fn) (realName fn) (intercalate "," (map castIfNecessary args))) (Self t, Just self) -> (printf "{\n %s (%s)(static_cast<%s*>(%s))->%s(%s);\n}" return t (className fn) self (realName fn) (intercalate "," (map castIfNecessary (tail args)))) _ -> "dunno" in header ++ body extractTypeName arg@(x:xs) = ((intercalate " " . init $ arg),(last arg)) extractTypeName [] = ("","") valueOrMe key table = case (lookup key table) of Just v -> v Nothing -> key toHaskell prefix (CPP (function, arguments)) = let oldTypeName = getArgumentType . argumentType name = toHaskellName (realName function) (\f -> if (isPrefixOf "Fl_" f) then (drop 3 f) else f) returnType = (valueOrMe (oldTypeName . argument $ function) simpleTypeMap, oldTypeName (argument function)) haskellArgs = map (\a -> ((argumentName a), (valueOrMe (oldTypeName a) simpleTypeMap, oldTypeName a))) arguments oldName = if (className function /= "") then (className function) ++ "_" ++ (realName function) else (realName function) in Haskell (prefix, oldName, name,returnType,haskellArgs) toHaskellName name firstPartFunc = case parse parseName "" name of Right (part:parts) -> let processedParts' = map (\p -> if (not $ null p) then ((upcase $ [head p]) ++ (tail p)) else p) parts surroundedByEmpty as = not (null as) && (null (head as)) && (null (last as)) headEmpty as = not (null as) && null (head as) lastEmpty as = not (null as) && null (last as) setLast x as | not (null as) = take (length as - 1) as ++ [x] setLast x _ = [x] setHead x as | not (null as) = [x] ++ drop 1 as setHead x _ = [x] ifDo p f xs = if (p xs) then f xs else xs processedParts = ifDo lastEmpty (setLast "_") (ifDo headEmpty (setHead "_") processedParts') processFirstThing = firstPartFunc part in intercalate "" ([processFirstThing] ++ processedParts) Left _ -> error "shouldn't happen" withMarshaller marshaller a = if (isPrefixOf "Ptr" a || isPrefixOf "FunPtr" a) then (Just "id") else lookup a marshaller type Arg = (String, (String,String)) data RectangleOrStandalone = Rectangle Arg Arg Arg Arg | StandAlone Arg | Position Arg Arg | ByX Arg | ByY Arg | ByXY Arg Arg | ReturnSize Arg Arg | ReturnRectangle Arg Arg Arg Arg | RGB Arg Arg Arg | Style Arg printHaskell (Haskell (prefix, oldName, name, returnType, haskellArgs)) = let addInMarshaller arg = case withMarshaller inMarshallMap arg of Just m -> m ++ " `" ++ arg ++ "'" Nothing -> "`" ++ arg ++ "'" addOutMarshaller arg = case withMarshaller outMarshallMap arg of Just m -> "`" ++ arg ++ "' " ++ m Nothing -> "`" ++ arg ++ "'" comment hArg cppArg = if (hArg == "Ptr ()") then "{- " ++ cppArg ++ " -}" else "" cppNameToHaskellName = map toLower nameToPtrName n = (cppNameToHaskellName n) ++ "Ptr" haskellFunction hArg = if ((fst . snd $ hArg) == "Ptr ()") then ("withRef " ++ (cppNameToHaskellName (fst hArg)) ++ " $ \\" ++ (nameToPtrName (fst hArg)) ++ " -> ") else "" toHaskellType arg = case (lookup arg haskellEquivalent) of Just a -> a ++ " a " Nothing -> case (lookup arg simpleTypeMap) of Just a' -> a' Nothing -> arg functionName = [(toUpper . head $ name)] ++ (tail name) haskellFunctionName = case prefix of (Just p) -> p ++ functionName Nothing -> name detectRectangleOrPosition (x@("X",(_,"int*")):y@("Y",(_,"int*")):w@("W",(_,"int*")):h@("H",(_,"int*")):args) = [ReturnRectangle x y w h] ++ detectRectangleOrPosition args detectRectangleOrPosition (x@("x",(_,"int*")):y@("y",(_,"int*")):w@("w",(_,"int*")):h@("h",(_,"int*")):args) = [ReturnRectangle x y w h] ++ detectRectangleOrPosition args detectRectangleOrPosition (x@("dx",(_,"int*")):y@("dy",(_,"int*")):w@("w",(_,"int*")):h@("h",(_,"int*")):args) = [ReturnRectangle x y w h] ++ detectRectangleOrPosition args detectRectangleOrPosition (w@("w",(_,"int*")):h@("h",(_,"int*")):args) = [ReturnSize w h] ++ detectRectangleOrPosition args detectRectangleOrPosition (w@("x",(_,"int*")):h@("y",(_,"int*")):args) = [ReturnSize w h] ++ detectRectangleOrPosition args detectRectangleOrPosition (x@("X",(_,_)):y@("Y",(_,_)):w@("W",(_,_)):h@("H",(_,_)):args) = [Rectangle x y w h] ++ detectRectangleOrPosition args detectRectangleOrPosition (x@("x",(_,_)):y@("y",(_,_)):w@("w",(_,_)):h@("h",(_,_)):args) = [Rectangle x y w h] ++ detectRectangleOrPosition args detectRectangleOrPosition (x@("x",(_,"int")):y@("y",(_,"int")):args) = [Position x y] ++ detectRectangleOrPosition args detectRectangleOrPosition (x@("X",(_,"int")):y@("Y",(_,"int")):args) = [Position x y] ++ detectRectangleOrPosition args detectRectangleOrPosition (x@("x",(_,"double")):y@("y",(_,"double")):args) = [ByXY x y] ++ detectRectangleOrPosition args detectRectangleOrPosition (x@("X",(_,"double")):y@("Y",(_,"double")):args) = [ByXY x y] ++ detectRectangleOrPosition args detectRectangleOrPosition (x@("x",(_,"double")):args) = [ByX x] ++ detectRectangleOrPosition args detectRectangleOrPosition (x@("X",(_,"double")):args) = [ByX x] ++ detectRectangleOrPosition args detectRectangleOrPosition (y@("y",(_,"double")):args) = [ByY y] ++ detectRectangleOrPosition args detectRectangleOrPosition (y@("Y",(_,"double")):args) = [ByY y] ++ detectRectangleOrPosition args detectRectangleOrPosition (r@("r",(_,"uchar")):g@("g",(_,"uchar")):b@("b", (_, "uchar")):args) = [RGB r g b] ++ detectRectangleOrPosition args detectRectangleOrPosition (style@("style",(_,"int")):args) = [Style style] ++ detectRectangleOrPosition args detectRectangleOrPosition (arg:args) = [StandAlone arg] ++ detectRectangleOrPosition args detectRectangleOrPosition [] = [] parsedArgs = detectRectangleOrPosition haskellArgs addRectangle ((Rectangle x y w h):args) = "let (x_pos', y_pos', width', height') = fromRectangle rectangle in\n" addRectangle _ = "" hasAllocated = any (\a -> case a of ReturnRectangle _ _ _ _ -> True ReturnSize _ _ -> True _ -> False) parsedArgs allocatedReturn = (concat (map (\a -> case a of ReturnRectangle _ _ _ _ -> ["Rectangle"] ReturnSize _ _ -> ["Size"] _ -> []) parsedArgs ) ) in printf "{# fun %s as %s { %s } -> %s #}\ninstance (impl ~ (%s)) => Op (%s ()) xxx orig impl where\n runOp _ _ %s" oldName (name ++ "'") (intercalate "," (concat (map (\a -> case a of StandAlone (_,(hArg,_)) -> [(addInMarshaller hArg)] Position (_,(hArg1,_)) (_,(hArg2,_)) -> [(addInMarshaller hArg1), (addInMarshaller hArg2)] RGB (_,(hArg1,_)) (_,(hArg2,_))(_,(hArg3,_)) -> [(addInMarshaller hArg1), (addInMarshaller hArg2), (addInMarshaller hArg3)] Style (_, (style,_)) -> [(addInMarshaller style)] ByX (_,(hArg,_)) -> [(addInMarshaller hArg)] ByY (_,(hArg,_)) -> [(addInMarshaller hArg)] ByXY (_,(hArg1,_)) (_,(hArg2,_)) -> [(addInMarshaller hArg1), (addInMarshaller hArg2)] Rectangle (_,(hArg1,_))(_,(hArg2,_))(_,(hArg3,_))(_,(hArg4,_)) -> [(addInMarshaller hArg1), (addInMarshaller hArg2), (addInMarshaller hArg3), (addInMarshaller hArg4)] ReturnSize _ _ -> [("alloca- `Int' peekIntConv*"), ("alloca- `Int' peekIntConv*")] ReturnRectangle _ _ _ _ -> [("alloca- `Int' peekIntConv*"), ("alloca- `Int' peekIntConv*"), ("alloca- `Int' peekIntConv*"), ("alloca- `Int' peekIntConv*")] ) parsedArgs ) ) ) (addOutMarshaller (fst returnType)) (intercalate " -> " ((map ( \a -> case a of StandAlone arg -> (toHaskellType . snd . snd) $ arg Position _ _ -> "Position" ByX _ -> "ByX" ByY _ -> "ByY" ByXY _ _ -> "ByXY" Rectangle _ _ _ _ -> "Rectangle" Style _ -> "LineStyle" RGB _ _ _ -> "RGB" ReturnSize _ _ -> "" ReturnRectangle _ _ _ _ -> "" ) parsedArgs) ++ [" IO (" ++ (intercalate "," (if (fst returnType == "()") then allocatedReturn else [(fst returnType)] ++ allocatedReturn) ) ++ ")" ] ) ) functionName ((intercalate " " (map ( \a -> case a of StandAlone arg -> (cppNameToHaskellName . fst) arg Position _ _ -> "(Position (X x_pos') (Y y_pos'))" ByX _ -> "(ByX by_x')" ByY _ -> "(ByY by_y')" ByXY _ _ -> "(ByXY by_x' by_y')" RGB _ _ _ -> "(r', g' , b')" Style _ -> "style" ReturnSize _ _ -> "" ReturnRectangle _ _ _ _ -> "" Rectangle x y w h -> "rectangle" ) parsedArgs)) ++ " = " ++ (concat (map (\a -> case a of Rectangle _ _ _ _ -> "let (x_pos', y_pos', width', height') = fromRectangle rectangle in " _ -> "" ) parsedArgs)) ++ (concat (map haskellFunction haskellArgs)) ++ (name ++ "'") ++ " " ++ (intercalate " " (map ( \hArg -> case hArg of StandAlone arg -> if ((fst . snd $ arg) == "Ptr ()") then (nameToPtrName (fst arg)) else (cppNameToHaskellName (fst arg)) ByX _ -> "by_x'" ByY _ -> "by_y'" ByXY _ _ -> "by_x' by_y'" Position _ _ -> "x_pos' y_pos'" Style _ -> "" RGB _ _ _ -> "r' g' b'" ReturnSize _ _ -> "" ReturnRectangle _ _ _ _ -> "" Rectangle _ _ _ _ -> "x_pos' y_pos' width' height'" ) parsedArgs ) ) ++ ( if hasAllocated then let allocatedArgs = map (\a -> case a of "Rectangle" -> ("rectangle'", "toRectangle") "Size" -> ("size'", "toSize") _ -> ("","") ) allocatedReturn in if (fst returnType == "()") then ">>= \\(" ++ (intercalate "," (map fst allocatedArgs)) ++ ") -> return $ (" ++ (intercalate "," (map (\a -> (snd a) ++ " " ++ (fst a)) allocatedArgs)) ++ ")" else ">>= \\(result, " ++ (intercalate "," (map fst allocatedArgs)) ++ ") -> return $ (result, " ++ (intercalate "," (map (\a -> (snd a) ++ " " ++ (fst a)) allocatedArgs)) ++ ")" else "" ) ) inMarshallMap = [ ("Boxtype", "cFromEnum") ,("Labeltype", "cFromEnum") ,("AlignType", "cFromEnum") ,("const SettingBool", "cFromEnum") ,("const SettingDouble", "cFromEnum") ,("const SettingChar", "cFromEnum") ,("Color", "cFromColor") ,("CUInt", "id") ,("FlShortcut", "id") ,("When", "cFromEnum") ,("Mode", "cFromEnum") ,("Cursor", "cFromEnum") ,("LineStyle", "cFromEnum") ,("Font", "cFromFont") ,("FontAttribute", "cFromFontAttribute") ,("Fontsize", "cFromFontsize") ] outMarshallMap = [ ("Boxtype", "cToEnum") ,("Labeltype", "cToEnum") ,("Color", "cToColor") ,("Font", "cToFont") ,("FontAttribute", "cToFontAttribute") ,("Fontsize", "cToFontsize") ,("When", "cToEnum") ,("FlShortcut", "id") ,("AlignType", "cToEnum") ,("Mode", "cToEnum") ,("Cursor", "cToEnum") ,("LineStyle", "cToEnum") ,("Region", "unsafeToObject") ] simpleTypeMap = [ ("void", "()") ,("int", "Int") ,("const unsigned", "Int") ,("void*", "Ptr ()") ,("double", "Double") ,("int*", "Ptr CInt") ,("char*", "String") ,("const char *", "String") ,("const char*", "String") ,("char* const*", "String") ,("const char* const*", "String") ,("const char * const", "String") ,("float", "Float") ,("uchar", "Word8") ,("float*", "Ptr CFloat") ,("unsigned", "Int") ,("unsigned int", "Int") ,("long long", "Double") ,("fl_Region", "Ptr ()") ,("Fl_Boxtype", "Boxtype") ,("Fl_Mode", "Mode") ,("fl_Scroll", "Ptr ()") ,("fl_Widget", "Ptr ()") ,("fl_Spinner", "Ptr ()") ,("fl_Tabs", "Ptr ()") ,("fl_Native_File_Chooser", "Ptr ()") ,("fl_Text_Buffer", "Ptr ()") ,("fl_Text_Selection", "Ptr ()") ,("fl_Text_Display" , "Ptr ()") ,("fl_Text_Editor" , "Ptr ()") ,("fl_Tree_Prefs", "Ptr ()") ,("fl_Tree_Item", "Ptr ()") ,("fl_Tree", "Ptr ()") ,("fl_Browser", "Ptr ()") ,("fl_Table", "Ptr ()") ,("fl_Adjuster", "Ptr ()") ,("fl_Timer", "Ptr ()") ,("fl_Progress", "Ptr ()") ,("fl_Input", "Ptr ()") ,("fl_Positioner", "Ptr ()") ,("fl_Counter", "Ptr ()") ,("fl_Scrollbar", "Ptr ()") ,("fl_Pack", "Ptr ()") ,("fl_Dial", "Ptr ()") ,("fl_Value_Slider", "Ptr ()") ,("fl_Value_Input", "Ptr ()") ,("fl_RGB_Image", "Ptr ()") ,("fl_Pixmap", "Ptr ()") ,("fl_Copy_Surface", "Ptr ()") ,("fl_Window", "Ptr ()") ,("fl_Overlay_Window", "Ptr ()") ,("fl_Group", "Ptr ()") ,("fl_Button", "Ptr ()") ,("fl_Valuator", "Ptr ()") ,("fl_Slider", "Ptr ()") ,("fl_Menu_Item", "Ptr ()") ,("fl_Menu_", "Ptr ()") ,("fl_Image", "Ptr ()") ,("fl_Image_Surface", "Ptr ()") ,("fl_Bitmap", "Ptr ()") ,("webviewC", "Ptr()") ,("Fl_Color", "Color") ,("Fl_Font", "Font") ,("Fl_Fontsize", "Fontsize") ,("Fl_FontAttribute", "FontAttribute") ,("Fl_Align", "AlignType") ,("Fl_Cursor", "Cursor") ,("Fl_Shortcut", "FlShortcut") ,("Fl_Labeltype", "Labeltype") ,("fl_Label_Draw_F*", "FunPtr LabelDrawFPrim") ,("fl_Label_Measure_F*", "FunPtr LabelMeasureFPrim") ,("fl_Box_Draw_F*", "FunPtr BoxDrawFPrim") ,("fl_Awake_Handler", "FunPtr AwakeHandlerPrim") ,("fl_Event_Handler", "FunPtr EventHandlerPrim") ,("fl_Timeout_Handler", "FunPtr TimeoutHandlerPrim") ,("fl_Abort_Handler", "FunPtr AbortHandlerPrim") ,("fl_Args_Handler", "FunPtr ArgsHandlerPrim") ,("fl_Atclose_Handler", "FunPtr AtCloseHandlerPrim") ,("fl_Atclose_Handler*", "Ptr (FunPtr AtCloseHandlerPrim)") ,("fl_Event_Dispatch*", "Ptr (FunPtr EventDispatchPrim)") ,("fl_Event_Dispatch", "FunPtr EventDispatchPrim") ,("fl_FD_Handler", "FunPtr FDHandlerPrim") ,("fl_Idle_Handler", "FunPtr IdleHandlerPrim") ,("fl_Old_Idle_Handler", "FunPtr OldIdleHandlerPrim") ,("fl_Event_Dispatch*", "Ptr (FunPtr EventDispatchPrim)") ,("Fl_Shortcut", "CUInt") ,("fl_Atclose_Handler*", "Ptr (FunPtr AtCloseHandler)") ,("fl_When", "When") ,("fl_Gl_Window", "Ptr ()") ] haskellEquivalent = [ ("fl_Region" , "Region"), ("fl_Widget" , "Widget"), ("fl_Spinner" , "Spinner"), ("fl_Tabs" , "Tabs"), ("fl_Native_File_Chooser" , "NativeFileChooser"), ("fl_Text_Buffer" , "TextBuffer"), ("fl_Text_Selection" , "TextSelection"), ("fl_Text_Display" , "TextDisplay"), ("fl_Text_Editor" , "TextEditor"), ("fl_Tree_Prefs" , "TreePrefs"), ("fl_Tree_Item" , "TreeItem"), ("fl_Tree" , "Tree"), ("fl_Browser" , "Browser"), ("fl_Table" , "Table"), ("fl_Adjuster" , "Adjuster"), ("fl_Timer" , "Timer"), ("fl_Progress" , "Progress"), ("fl_Input" , "Input"), ("fl_Positioner" , "Positioner"), ("fl_Counter" , "Counter"), ("fl_Scrollbar" , "Scrollbar"), ("fl_Pack" , "Pack"), ("fl_Scroll" , "Scroll"), ("fl_Dial" , "Dial"), ("fl_Value_Slider" , "ValueSlider"), ("fl_Value_Input" , "ValueInput"), ("fl_RGB_Image" , "RGBImage"), ("fl_Pixmap" , "Pixmap"), ("fl_Copy_Surface" , "CopySurface"), ("fl_Window" , "Window"), ("fl_Overlay_Window" , "OverlayWindow"), ("fl_Group" , "Group"), ("fl_Gl_Window" , "GlWindow"), ("fl_Button" , "Button"), ("fl_Valuator" , "Valuator"), ("fl_Slider" , "Slider"), ("fl_Image" , "Image"), ("fl_Image_Surface" , "ImageSurface"), ("fl_Menu_Item" , "MenuItem"), ("fl_Menu_" , "MenuPrim"), ("fl_Bitmap" , "Bitmap"), ("webviewC" , "Webview") ] upcase = map toUpper makeArgument className argType argName = case ((upcase argType == upcase className), (isPrefixOf "fl_" argType)) of (True, True) -> Argument (Self argType) argName ("F" ++ (tail argType)) (True, False) -> Argument (Self argType) argName argType (False, True) -> Argument (Normal argType) argName ("F" ++ (tail argType)) (False, False) -> Argument (Normal argType) argName argType parseArgList = (many (letter <|> digit <|> char '_' <|> char '*' <|> char '&')) `sepBy` (skipMany1 space) >>= return . filter (/= "") parseName = (many (letter <|> digit)) `sepBy` (char '_') extractClassName' functionName@(x:xs) accum | (x == "Fl") = extractClassName' xs x extractClassName' functionName@(x1:x2:xs) accum | (x1 == "") && (x2 /= "") = accum ++ x1 ++ "_" extractClassName' functionName@(x:xs) accum | (x == "") && (null xs) = accum extractClassName' functionName@(x:xs) accum | (x == "") = extractClassName' xs (accum ++ "_") extractClassName' functionName@(x:xs) accum | (x /= "") && (isUpper(head x))= extractClassName' xs (accum ++ "_" ++ x) extractClassName' functionName@(x:xs) accum = extractClassName' xs accum extractClassName' [] accum = accum extractClassName functionName = extractClassName' functionName "" parseTypeName = do string exportMacro char '(' spaces typeString <- parseArgList >>= return . intercalate " " spaces char ',' spaces (className, functionName) <- parseName >>= return . (\f -> (extractClassName f, intercalate "_" f)) spaces char ')' let realName = if ((not $ isInfixOf "New" functionName) && isPrefixOf className functionName) then if (length className == 0) then functionName else drop (length $ className ++ "_") functionName else functionName return $ FunctionName realName className (makeArgument className typeString functionName) inBlock start end accumulatedInput level levelp p parsed = do { try (char start); inBlock' start end accumulatedInput level levelp p parsed } inBlock' start end accumulatedInput level levelp p parsed = do { try (char end); if (levelp level) then case parse p "" accumulatedInput of Right parsed -> return (Just parsed) Left err -> return Nothing else return Nothing } <|> do { x <- inBlock start end accumulatedInput (level + 1) levelp p parsed; inBlock' start end "" level levelp p x } <|> do { x <- if (levelp level) then many (noneOf [start,end]) else skipMany (noneOf [start,end]) >> return ""; inBlock' start end (accumulatedInput ++ x) level levelp p parsed } parseImplementation = do functionSignature <- parseTypeName spaces arguments <- parseArguments (className functionSignature) spaces actualFunctionName <- case functionSignature of FunctionName _ _ (Argument (Self _) _ _) -> do {skipFunctionBody; return Nothing} FunctionName _ _ (Argument (Normal _) _ _) -> (inBlock '{' '}' "" 0 (== 0) grabFlCall Nothing) <|> do { skipFunctionBody; return Nothing} case actualFunctionName of Just n -> return (arguments,functionSignature {realName = n}) Nothing -> return (arguments, functionSignature) where skipFunctionBody = inBlock '{' '}' "" 0 (== 0) (many anyChar) Nothing grabFlCall = do manyTill (noneOf "{}") (string "static_cast"); manyTill (noneOf "\n") (string "->") name <- manyTill (noneOf "{}") (try (string "(")) return name ignoreUntil e p = scan where scan = try (do {x <- e; return x}) <|> do {p; x <- scan; return x} parseCPP p = do manyTill anyChar (try (string "EXPORT {")) impls <- many (try (ignoreUntil p (noneOf "{}"))) manyTill anyChar (char '}') return impls parseArguments className = do char '(' spaces arguments <- do args <- parseArgList `sepBy` (char ',') if (not (null (head args))) then return $ map (uncurry (makeArgument className) . extractTypeName) args else return [] spaces char ')' return arguments parseTypeSignature = do spaces typeName <- parseTypeName arguments <- parseArguments (className typeName) char ';' spaces return $ CPP (typeName, arguments) replaceSquareBrackets = map translateSquareBracket where translateSquareBracket '[' = '(' translateSquareBracket ']' = ')' translateSquareBracket x = x parseAndProcess parser input f = case parse parser "" input of Right output -> f output Left err -> error (show err) data ParseOutputType = Haskell (Maybe String, String, String,(String,String),[(String, (String,String))]) | CPP (FunctionName, [Argument]) deriving Show main = do (argType:arg:args) <- getArgs case argType of "string" -> parseAndProcess parseTypeSignature arg (putStrLn . outputDefaultImplementation) "" -> parseAndProcess parseTypeSignature arg (printHaskell . (toHaskell Nothing)) prefix -> parseAndProcess parseTypeSignature arg (printHaskell . (toHaskell (Just prefix))) testHaskellName input = parseAndProcess parseTypeSignature input (printHaskell . (toHaskell (Just "test"))) generateFunctionPointers :: [([Argument],FunctionName)] -> String generateFunctionPointers impls = printf "struct blah {\n%s\n};" (intercalate ";\n" (map generateFunctionPointer impls)) generateFunctionPointer :: ([Argument], FunctionName) -> String generateFunctionPointer (args, FunctionName _ _ name@(Argument argType argName argRealType)) = printf "%s (*%s)(%s)" (getArgumentType argType) ("f" ++ (tail argName)) (intercalate "," (map (ppArgument " ") args)) generateDerivedMethod :: ([Argument], FunctionName) -> String generateDerivedMethod impl = let returnType = getArgumentType (argumentType . argument . snd $ impl) cppReturnType = if (isPrefixOf "fl" returnType) then "F" ++ (tail returnType) ++ "*" else returnType functionName = realName (snd impl) cppClass = className $ snd impl makeArgList prettyPrinter args = intercalate "," (map prettyPrinter args) cppArgList prettyPrinter = makeArgList prettyPrinter (case (fst impl) of ((Argument (Self _) _ _):args) -> args _ -> (fst impl)) cppArgListSignature = cppArgList (ppCPPArgument " ") cppArgListPassing = cppArgList argumentName functionPointerArgList = case (fst impl) of ((Argument (Self s) _ _):args) -> case (makeArgList (\arg -> if (needsCasting arg) then backCast arg (argumentName arg) else (argumentName arg)) args) of as@(x:xs) -> "(" ++ s ++ ") this," ++ as _ ->"(" ++ s ++ ") this" _ -> makeArgList argumentName (fst impl) functionPointer = "f" ++ (tail (argumentName . argument . snd $ impl)) callFunctionPointer :: String callFunctionPointer = printf "this->overriddenFuncs->%s(%s)" functionPointer functionPointerArgList returnResult :: String returnResult = if (returnType /= "void") then printf "%s result = %s;\n return %s;" returnType callFunctionPointer (if (needsCasting (argument . snd $ impl)) then cast (argument . snd $ impl) "result" else "result") else printf "%s;" callFunctionPointer in printf "%s %s::%s(%s){\n if (this->overriddenFuncs->%s != NULL) {\n %s \n}\nelse {\n %s::%s(%s);\n}\n}\n" cppReturnType (cppClass ++ "Derived") functionName cppArgListSignature functionPointer returnResult cppClass functionName cppArgListPassing printImplementation sig = case parse parseTypeSignature "" sig of Right output -> outputDefaultImplementation output Left err -> show err