module Main where

import Data.Char as Char hiding (isSymbol)
import Data.List as List (nub, isPrefixOf, sortBy)
import Data.Maybe as Maybe (catMaybes)
import Control.Monad (unless)
import System.Environment (getArgs)

main = do
  [name, original, modified] <- getArgs
  diff name original modified

diff :: String -> FilePath -> FilePath -> IO ()
diff moduleName originalFile modifiedFile = do
  original <- readFile originalFile
  modified <- readFile modifiedFile
  let (added, removed, changed) =
        classify (extractFunctionsFromHi original)
                 (extractFunctionsFromHi modified)

--  putStrLn "Functions added:"
--  mapM_ putStrLn added

  unless (null removed && null changed) $
    putStrLn ("module " ++ moduleName)

  unless (null removed) $ do
    putStrLn " functions removed:"
    mapM_ (putStrLn . ("  "++)) removed
    putStrLn ""

  unless (null changed) $ do
    putStrLn " functions changed:"
    mapM_ putStrLn [ "  " ++ name ++ " changed from"
                          ++ "\n     :: " ++ originalType
                          ++ "\n  to :: " ++ modifiedType
                   | (name, originalType, modifiedType) <- changed ]
    putStrLn ""


classify :: [(String, String)] -> [(String, String)] -> ([String], [String], [(String, String, String)])
classify originalFuns modifiedFuns =
  ( [ originalName | (originalName, originalType) <- added ]
  , [ modifiedName | (modifiedName, modifiedType) <- removed
    , not $ "lvl" `isPrefixOf` modifiedName
    , not $ "gtk_" `isPrefixOf` modifiedName ]
  , [ (originalName, originalType, modifiedType)
    | ((originalName, originalType), (modifiedName, modifiedType)) <- changed
    ,    canonicaliseQuantifiedVars originalType
      /= canonicaliseQuantifiedVars modifiedType] )
  where (removed, changed, added) =
          mergeBy (comparing fst)
                  (sortBy (comparing fst) originalFuns)
                  (sortBy (comparing fst) modifiedFuns)


canonicaliseQuantifiedVars :: String -> String
canonicaliseQuantifiedVars ty =
  unwords [ case lookup w varMapping of
              Nothing -> w
              Just w' -> w'
          | w <- words ty ]
  where quantifiedVars = [ w | w@(c:_) <- words ty, Char.isLower c ]
        varMapping = zip (List.nub quantifiedVars) (map (\c -> [c]) ['a'..'z'])


-- mergeBy cmp xs ys = (only_in_xs, in_both, only_in_ys)
mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> ([a], [(a, b)], [b])
mergeBy cmp = merge [] [] []
  where merge l m r []     ys     = (reverse l, reverse m, reverse (ys++r))
        merge l m r xs     []     = (reverse (xs++l), reverse m, reverse r)
        merge l m r (x:xs) (y:ys) = 
          case x `cmp` y of
            GT -> merge    l         m  (y:r) (x:xs)    ys
            EQ -> merge    l  ((x,y):m)    r     xs     ys
            LT -> merge (x:l)        m     r     xs  (y:ys)

comparing :: (Ord a) => (b -> a) -> b -> b -> Ordering
comparing p x y = compare (p x) (p y)


-- returns a list of function names with their types
extractFunctionsFromHi :: String -> [(String, String)]
extractFunctionsFromHi = catMaybes . map (eval . lexer) . init . parse


ignore = ["module", "__interface", "__export", "package", "orphans",
          ";", "$", "import", ":", "infixr", "infixl", "infix", "("]

eval :: [String] -> Maybe (String, String)
eval (x:_) | x `elem` ignore = Nothing


eval ("instance":ls) = Nothing
eval ("type":ls) = Nothing
eval ("data":ls) = Nothing
-- functions
eval ls@(name:"::":type_) = Just (name, respace (filterBraces type_))
eval xs = Nothing

filterBraces ("{":"}":xs) = filterBraces xs
filterBraces (x:xs) = x : filterBraces xs
filterBraces [] = []

respace :: [String] -> String
respace x = f (filter (/= ";") x)
    where
        f [] = ""
        f [x] = x
        f (x1:x2:xs) = if shouldspace x1 x2
                       then x1 ++ " " ++ f (x2:xs)
                       else x1 ++        f (x2:xs)

lBrack = "({["
rBrack = ")}]"

isRight [x] = x `elem` rBrack
isRight _ = False

isLeft [x] = x `elem` lBrack
isLeft _ = False


shouldspace l r = not $
    isRight r || isLeft l || r == ","


splitTerms :: [String] -> [[String]]
splitTerms xs@(x:_) | isLeft x = left : splitTerms (drop (length left) xs)
    where
        left = readBrack 0 xs
        
        readBrack 1 (x:xs) | isRight x = [x]
        readBrack n (x:xs) | isRight x = x : readBrack (n-1) xs
                           | isLeft  x = x : readBrack (n+1) xs
                           | otherwise = x : readBrack   n   xs

splitTerms (x:xs) = [x] : splitTerms xs
splitTerms [] = []
        
        

splitOn :: Eq a => a -> [a] -> [[a]]
splitOn x [] = []
splitOn x as = takeWhile (/= x) as : splitOn x (safeTail (dropWhile (/= x) as))


safeTail (x:xs) = xs
safeTail [] = []



parse :: String -> [String]
parse xs = rejoin (lines xs)
    where
        rejoin (x1:x2@(x2h:x2t):xs) | isSpace x2h = rejoin ((x1 ++ " " ++ dropWhile isSpace x2) : xs)
        rejoin (x:xs) = x : rejoin xs
        rejoin [] = []


lexer :: String -> [String]
lexer = demodule . lexRaw

demodule :: [String] -> [String]
demodule ("(":".":xs) = "(":".": demodule xs
demodule (x:".":xs) = demodule xs
demodule (x:xs) = x : demodule xs
demodule [] = []


-- Chunks taken from NHC's lexer, with modifications
lexRaw :: String -> [String]

lexRaw "" = []
lexRaw (x:xs) | isSpace x = lexRaw xs

lexRaw (x:xs) | x == '\'' || x == '\"' = f [x] xs
    where
        f done [] = [reverse done]
        f done ('\\':x:xs) = f (x:'\\':done) xs
        f done (a:xs) | a == x = reverse (a:done) : lexRaw xs
                      | otherwise = f (a:done) xs

lexRaw ('{':'-':x) = f x
    where
        f ('-':'}':x) = lexRaw x
        f (x:xs) = f xs
        f [] = []
        
lexRaw ('[':']':xs) = "[]" : lexRaw xs
lexRaw ('(':')':xs) = "()" : lexRaw xs

lexRaw ('(':x:xs) | isSymbol x && b == ')' = a : lexRaw bs
    where (a, b:bs) = span isSymbol (x:xs)

lexRaw (x:xs) | x `elem` ",;()[]{}`" = [x] : lexRaw xs
              | isDigit x = lexRaw xs -- drop digits, not needed -- continue isDigit
              | isSymbol x = continue isSymbol
              | isIdFirst x = continue isIdAny
    where
        isIdFirst c = isAlpha c || c == '_'
        isIdAny c = isAlphaNum c || c `elem` "_'#"
        
        continue f = a : lexRaw b
            where (a, b) = span f (x:xs)

isSymbol c = c `elem` "!@#$%&*+./<=>?\\^|:-~"

{-

lex (c:s) | isSingle c  = [([c],s)]
      | isSym c = [(c:sym,t)         | (sym,t) <- [span isSym s]]
      | isIdInit c  = [(c:nam,t)         | (nam,t) <- [span isIdChar s]]
      | isDigit c   = [(c:ds++fe,t)      | (ds,s)  <- [span isDigit s],
                           (fe,t)  <- lexFracExp s     ]
      | otherwise   = []    -- bad character

        where
        isSingle c  =  c `elem` ",;()[]{}`"
        isSym c     =  c `elem` "!@#$%&*+./<=>?\\^|:-~"
        isIdInit c  =  
        isIdChar c  =  isAlphaNum c || c `elem` "_'"

        lexFracExp ('.':c:s) | isDigit c
                                   = [('.':ds++e,u) | (ds,t) <- lexDigits (c:s),
                              (e,u)  <- lexExp t    ]
        lexFracExp s       = lexExp s

        lexExp (e:s) | e `elem` "eE"
             = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
                           (ds,u) <- lexDigits t] ++
               [(e:ds,t)   | (ds,t) <- lexDigits s]
        lexExp s = [("",s)] 



lexRaw "" = []
lexRaw (' ':x) = lexRaw x
lexRaw (';':x) = lexRaw x

-- to make up for Hugs being wrong
lexRaw ('_':x) = lexRaw x

lexRaw ('{':'-':x) = f x
    where
        f ('-':'}':x) = lexRaw x
        f (x:xs) = f xs
        f [] = []

lexRaw x  = a : lexRaw b
    where [(a, b)] = lex x
-}