#!/bin/runhaskell
{-# LANGUAGE FlexibleContexts #-}
import Control.Monad
import Text.Parsec
import Text.Parsec.String
import Data.List
import System.Environment
import Data.Char
import Data.List
import Text.Printf
import Control.Monad
import Debug.Trace
import System.Process
import Data.Maybe
import Control.Arrow

parseFunc = do
  char '('
  spaces
  f <- manyTill anyChar (try newline)
  spacesOrNewLines
  return f

parseFuncs = do
  spacesOrNewLines
  fs <- many parseFunc
  return (filter (\f -> not (all ((==) ')') f)) fs)

parseFuncsLine o = do
  let searchString = "type" ++ " " ++ o ++ "Funcs" ++ " " ++ "="
  manyTill anyChar (try (string searchString))
  parseFuncs

spacesOrNewLines =
  skipMany $ (char ' ') <|> (char '\n') <|> crlf

parseInstances = go False (return ([],[]))
  where
    go inIfdef accum = ((try (eof >> accum)) <|>
                        (try (do
                            newline >> string "#if FL_API_VERSION == 10304" >> endOfLine
                            go True accum)) <|>
                        (try (do
                            newline >> string "#endif" >> endOfLine
                            go False accum)) <|>
                        (try (do
                            newline >> string "instance"
                            (soFar, newVersionOnly)<- accum
                            opInstance <- parseInstance
                            go inIfdef
                               (return
                                 (if inIfdef
                                  then (soFar, newVersionOnly ++ [opInstance])
                                  else (soFar ++ [opInstance], newVersionOnly))))) <|>
                        (anyChar >> go inIfdef accum))
parseInstance = do
  spaces
  char '('
  spacesOrNewLines
  constraints <- manyTill anyChar (try (string "impl"))
  spacesOrNewLines
  char '~'
  spacesOrNewLines
  typeSig <- (try
                (do
                   char '('
                   sig <- go (1 :: Int) ""
                   spacesOrNewLines
                   char ')'
                   return sig) <|>
              (go (1 :: Int) ""))
  spacesOrNewLines
  string "=>"
  spacesOrNewLines
  string "Op"
  spacesOrNewLines
  char '('
  methodName <- word
  spacesOrNewLines
  char '('
  spacesOrNewLines
  char ')'
  spacesOrNewLines
  char ')'
  spacesOrNewLines
  widgetType <- word
  return (constraints, typeSig, methodName, widgetType)
  where
    go nesting accum =
      (try $ char '(' >> go (nesting + 1) (accum ++ "(")) <|>
      (try $ lookAhead (char ')') >>
             if (nesting == 0)
               then parserZero
               else if (nesting == 1)
                      then char ')' >> return accum
                      else char ')' >> go (nesting - 1) (accum ++ ")")) <|>
      (do
         bare <- manyTill anyChar ((lookAhead (char ')')) <|> (lookAhead (char '(')))
         go nesting (accum ++ bare))

runHierarchyParser = do
  spaces
  string "type"
  spaces
  widgetType <- word
  spaces
  string "="
  spaces
  _ <- word
  spaces
  parent <- many anyChar
  return (widgetType, parent)
className = "Op"

lowerFirst m = [(toLower $ head m)] ++ (tail m)
quoteDatatypes l =
  unwords $
  map
  (\w -> let (quoted, quoteBeginning) =
               if (any isUpper w)
               then let (non, w') = span (not . isUpper) w
                    in
                     (True, non ++ "'" ++ w')
               else (False, w)
         in
          if quoted
          then
            let (non, rw') = span (not . isAlphaNum) (reverse quoteBeginning)
            in
             reverse rw' ++ "'" ++ non
          else w
  )
  (words l)
pprint r = case r of
  (("",impl), methodDatatype, widgetName) ->
    (lowerFirst methodDatatype)
    ++ " :: "
    ++ "'Ref' '" ++ widgetName
    ++ "'" ++ " -> "
    ++ quoteDatatypes impl
  ((c ,impl), methodDatatype, widgetName) ->
    (lowerFirst methodDatatype) ++
    "::" ++ " "
    ++ "(" ++ (quoteDatatypes (reverse (drop 2 (reverse c)))) ++ ")" ++ " => "
    ++ "'Ref' '" ++ widgetName
    ++ "'" ++ " -> "
    ++ quoteDatatypes impl

word = manyTill anyChar (try (string " "))

isWidget w ((_,_),_,w') = w == w'
data Command = Functions String | Hierarchy String | Sync | CheckHierarchies

traceHierarchy :: String -> [String] -> [(String,String)] -> [String]
traceHierarchy w accum dict = case (lookup w dict) of
  Nothing -> accum
  (Just w') -> traceHierarchy w' (accum ++ [w]) dict

main = do
  args <- getArgs
  let command =
        case args of
          ("functions":w':[]) -> Just (Functions w')
          ("hierarchy":w':[]) -> Just (Hierarchy w')
          ("sync":[]) -> Just Sync
          ("checkHierarchies":[]) -> Just CheckHierarchies
          _ -> Nothing
  hierarchyContents <- readFile "../src/Graphics/UI/FLTK/LowLevel/Hierarchy.hs"
  let objs = (
               filter (not . isInfixOf "Funcs") .
               filter (isPrefixOf "type") .
               lines
             ) hierarchyContents
  let readWidgetFile w =
        readFile $
          if (isSuffixOf "Base" w)
          then "../src/Graphics/UI/FLTK/LowLevel/Base/" ++ (reverse . drop 4 . reverse $ w) ++ ".chs"
          else "../src/Graphics/UI/FLTK/LowLevel/" ++ w ++ ".chs"
  let parseWidgetFile contents =
        case (parse parseInstances "" contents) of
          Left err        -> error (show err)
          Right (functions, newVersionOnly) -> (Just functions, Just newVersionOnly)
  let hier' = catMaybes
                (
                  map
                    (\o -> case (parse runHierarchyParser "" o) of
                       Left err -> Nothing
                       Right r  -> Just r)
                    objs
                )
      funcs =
        catMaybes
          (map
            (\(o,_) ->
               case (parse (parseFuncsLine o) "" hierarchyContents) of
                 Left err -> Nothing
                 Right r  -> Just (o,r)
            )
            hier')
  case command of
    Nothing -> error ""
    (Just (Hierarchy w)) -> do
      let trace' = reverse $
            map (\w -> "-- " ++ w) $
              map (\w -> "\"" ++ w ++ "\"") $
                map (\w -> "Graphics.UI.FLTK.LowLevel." ++
                      (if (isSuffixOf "Base" w)
                       then "Base." ++ (reverse . drop 4 . reverse $ w)
                       else w)) $
                  traceHierarchy w [] hier'
      putStr $ concat $ intersperse "\n--  |\n--  v\n" trace'
    (Just (Functions w)) -> do
      contents <- readWidgetFile w
      let (functions, inNewVersionOnly) = parseWidgetFile contents
      let rendered = maybe [] (sort . map (\(c, sig, mName, wType) -> pprint ((c, sig), mName, wType)))
      putStr $ intercalate "\n--\n" (map ((++) "-- ") (rendered functions))
    (Just CheckHierarchies) -> 
      print
        (foldl
          (\badHierarchies (o,parentO) ->
             maybe
               badHierarchies
               (\_ ->
                 if (not (parentO == (o ++ "Base")))
                 then badHierarchies ++ [o]
                 else badHierarchies)
               (lookup (o ++ "Base") hier'))
           [] hier')
    (Just Sync) ->
      mapM
        (\(w,hierarchyFs) -> do
            contents <- readWidgetFile w
            let (fs, _) = parseWidgetFile contents
            let omitted =
                  case fs of
                    Nothing -> ([],[])
                    Just _fs ->
                      let namesOnly = map (\(_,_,nName,_) -> nName) _fs
                      in
                      if (not $ all (\(_,_,_,w') -> w' == w) _fs)
                      then error (show (w, (map (\(_,_,_,w') -> w') _fs)))
                      else
                        (
                          filter
                            (\f ->
                                 not (elem f namesOnly)
                            )
                            hierarchyFs
                        , filter
                            (\n -> not (elem n hierarchyFs))
                            namesOnly
                        )
            return (w,omitted)
        )
        funcs
       >>= print
      -- putStr "\n"
      -- putStr $ "\n-- Available in FLTK 1.3.4 only: \n"
      -- putStr $ intercalate "\n--\n" (map ((++) "-- ") (rendered inNewVersionOnly))
      -- putStr "\n"