content: #!/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
  