content: module Main (main) where
  
  import Control.Monad.State
  import Data.Char
  import Data.List
  import System.Directory
  import System.Environment
  import System.FilePath
  
  import BuildInfo
  import FilenameDescr
  import Change
  import Utils
  import Tar
  
  -- TODO:
  -- * Check installed trees too
  -- * Check hashbangs
  
  sizeChangeThresholds :: [(Integer,  -- Threshold only applies if one of
                                      -- the files is at least this big
                            Integer)] -- Size changed if the larger file's
                                      -- size is at least this %age of the
                                      -- smaller file's size
  sizeChangeThresholds = [(     1000, 150),
                          (50 * 1000, 110)]
  
  main :: IO ()
  main = do args <- getArgs
            (ignoreSizeChanges, p1, p2) <-
                case args of
                [p1, p2]                          -> return (False, p1, p2)
                ["--ignore-size-changes", p1, p2] -> return (True,  p1, p2)
                _ -> die ["Bad args. Need 2 filepaths."]
            doFileOrDirectory ignoreSizeChanges p1 p2
  
  doFileOrDirectory :: Bool -> FilePath -> FilePath -> IO ()
  doFileOrDirectory ignoreSizeChanges p1 p2
   = do b <- doesDirectoryExist p1
        let doit = if b then doDirectory else doFile
        doit ignoreSizeChanges p1 p2
  
  doDirectory :: Bool -> FilePath -> FilePath -> IO ()
  doDirectory ignoreSizeChanges p1 p2
   = do fs1 <- getDirectoryContents p1
        fs2 <- getDirectoryContents p2
        let isVersionChar c = isDigit c || c == '.'
            mkFileInfo "." = return []
            mkFileInfo ".." = return []
            mkFileInfo fp@('g':'h':'c':'-':x:xs)
             | isDigit x = return [(("ghc-", "VERSION", dropWhile isVersionChar xs), fp)]
             | otherwise = die ["No version number in " ++ show fp]
            mkFileInfo fp = do warn ["Unrecognised filename " ++ show fp]
                               return []
        fss1' <- mapM mkFileInfo fs1
        fss2' <- mapM mkFileInfo fs2
        let fs1' = sort $ concat fss1'
            fs2' = sort $ concat fss2'
  
            putBreak = putStrLn "=========="
            extraFile d fp = do putBreak
                                putStrLn ("Extra file in " ++ show d
                                       ++ ": " ++ show fp)
            doFiles [] [] = do putBreak
                               putStrLn "Done."
            doFiles ((_, fp) : xs) [] = do extraFile p1 fp
                                           doFiles xs []
            doFiles [] ((_, fp) : ys) = do extraFile p2 fp
                                           doFiles [] ys
            doFiles xs@((fpc1, fp1) : xs') ys@((fpc2, fp2) : ys')
                = do case fpc1 `compare` fpc2 of
                         EQ ->
                             do putBreak
                                putStrLn $ unwords ["Doing", show fp1, show fp2]
                                doFile ignoreSizeChanges (p1 </> fp1)
                                                         (p2 </> fp2)
                                doFiles xs' ys'
                         LT -> do extraFile p1 fp1
                                  doFiles xs' ys
                         GT -> do extraFile p2 fp2
                                  doFiles xs ys'
        doFiles fs1' fs2'
  
  doFile :: Bool -> FilePath -> FilePath -> IO ()
  doFile ignoreSizeChanges bd1 bd2
   = do tls1 <- readTarLines bd1
        tls2 <- readTarLines bd2
        let mWays1 = findWays tls1
            mWays2 = findWays tls2
        wayDifferences <- case (mWays1, mWays2) of
                          (Nothing, Nothing) ->
                              return []
                          (Just ways1, Just ways2) ->
                              return $ diffWays ways1 ways2
                          _ ->
                              die ["One input has ways, but the other doesn't"]
        (content1, tvm1) <- dieOnErrors $ mkContents mWays1 tls1
        (content2, tvm2) <- dieOnErrors $ mkContents mWays2 tls2
        let sortedContent1 = sortByFst content1
            sortedContent2 = sortByFst content2
            (nubProbs1, nubbedContent1) = nubContents sortedContent1
            (nubProbs2, nubbedContent2) = nubContents sortedContent2
            differences = compareContent mWays1 nubbedContent1
                                         mWays2 nubbedContent2
            allProbs = map First nubProbs1 ++ map Second nubProbs2
                    ++ diffThingVersionMap tvm1 tvm2
                    ++ wayDifferences
                    ++ differences
            wantedProbs = if ignoreSizeChanges
                          then filter (not . isSizeChange) allProbs
                          else allProbs
        mapM_ (putStrLn . pprFileChange) wantedProbs
  
  -- *nix bindists have ways.
  -- Windows "bindists", install trees, and testsuites don't.
  findWays :: [TarLine] -> Maybe Ways
  findWays tls = msum $ map f tls
      where f tl = case re regex (tlFileName tl) of
                   Just [dashedWays] -> Just (unSepList '-' dashedWays)
                   _                 -> Nothing
            regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell"
  
  diffWays :: Ways -> Ways -> [FileChange]
  diffWays ws1 ws2 = f (sort ws1) (sort ws2)
      where f [] [] = []
            f xs [] = map (First  . ExtraWay) xs
            f [] ys = map (Second . ExtraWay) ys
            f xs@(x : xs') ys@(y : ys')
                = case x `compare` y of
                  LT -> First  (ExtraWay x) : f xs' ys
                  GT -> Second (ExtraWay y) : f xs  ys'
                  EQ ->                       f xs' ys'
  
  diffThingVersionMap :: ThingVersionMap -> ThingVersionMap -> [FileChange]
  diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2)
      where f [] [] = []
            f xs [] = map (First  . ExtraThing . fst) xs
            f [] ys = map (Second . ExtraThing . fst) ys
            f xs@((xt, xv) : xs') ys@((yt, yv) : ys')
                = case xt `compare` yt of
                  LT -> First  (ExtraThing xt) : f xs' ys
                  GT -> Second (ExtraThing yt) : f xs  ys'
                  EQ -> let this = if xv == yv
                                   then []
                                   else [Change (ThingVersionChanged xt xv yv)]
                        in this ++ f xs' ys'
  
  mkContents :: Maybe Ways -> [TarLine]
             -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap)
  mkContents mWays tls
      = case runStateT (mapM f tls) (emptyBuildInfo mWays) of
        Nothing -> Left ["Can't happen: mkContents: Nothing"]
        Just (xs, finalBuildInfo) ->
            case concat $ map (checkContent finalBuildInfo) xs of
            []   -> Right (xs, biThingVersionMap finalBuildInfo)
            errs -> Left errs
      where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
                      return (fnd, tl)
  
  nubContents :: [(FilenameDescr, TarLine)]
              -> ([Change], [(FilenameDescr, TarLine)])
  nubContents [] = ([], [])
  nubContents [x] = ([], [x])
  nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
   | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs')
   | otherwise  = (ps, x1 : xs')
      where (ps, xs') = nubContents xs
  
  mkFilePathDescr :: FilePath -> BIMonad FilenameDescr
  mkFilePathDescr fp
   | Just [ghcVersion, _, middle, filename]
       <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
      = do haveThingVersion "ghc" ghcVersion
           middle' <- mkMiddleDescr middle
           filename' <- mkFileNameDescr filename
           let fd = FP "ghc-" : VersionOf "ghc" : middle' ++ FP "/" : filename'
           return $ normaliseDescr fd
   | otherwise = return [FP fp]
  
  mkMiddleDescr :: FilePath -> BIMonad FilenameDescr
  mkMiddleDescr middle
   -- haddock docs in a Windows installed tree
   | Just [thing, thingVersion, _, src]
         <- re ("^/doc/html/libraries/([^/]*)-" ++ versionRE ++ "(/src)?$")
               middle
      = do haveThingVersion thing thingVersion
           return [FP "/doc/html/libraries/",
                   FP thing, FP "-", VersionOf thing, FP src]
        `mplus` unchanged
   -- libraries in a Windows installed tree
   | Just [thing, thingVersion, _, rest]
         <- re ("^/lib/([^/]*)-" ++ versionRE ++ "(/.*)?$")
               middle
      = do haveThingVersion thing thingVersion
           return [FP "/lib/", FP thing, FP "-", VersionOf thing, FP rest]
        `mplus` unchanged
   -- Windows in-tree gcc
   | Just [prefix, _, _, gccVersion, _, rest]
         <- re ("^(/mingw/(lib(exec)?/gcc/mingw32/|share/gcc-))" ++ versionRE ++ "(/.*)?$")
               middle
      = do haveThingVersion "gcc" gccVersion
           return [FP prefix, VersionOf "gcc", FP rest]
        `mplus` unchanged
   | otherwise = unchanged
      where unchanged = return [FP middle]
  
  mkFileNameDescr :: FilePath -> BIMonad FilenameDescr
  mkFileNameDescr filename
   | Just [prog, ghcVersion, _, exe]
         <- re ("^(ghc|ghci|ghcii|haddock)-" ++ versionRE ++ "(\\.exe|\\.sh|)$")
               filename
      = do haveThingVersion "ghc" ghcVersion
           return [FP prog, FP "-", VersionOf "ghc", FP exe]
        `mplus` unchanged
   | Just [thing, thingVersion, _, ghcVersion, _, soDll]
         <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
               filename
      = do haveThingVersion "ghc" ghcVersion
           haveThingVersion thing thingVersion
           return [FP "libHS", FP thing, FP "-", VersionOf thing,
                   FP "-ghc", VersionOf "ghc", FP ".", FP soDll]
        `mplus` unchanged
   | Just [way, thingVersion, _, soDll]
         <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
               filename
      = do haveThingVersion "ghc" thingVersion
           return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
                   FP ".", FP soDll]
        `mplus` unchanged
   | Just [thingVersion, _, soDll]
         <- re ("^libHSffi-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
               filename
      = do haveThingVersion "ghc" thingVersion
           return [FP "libHSffi-ghc", VersionOf "ghc", FP ".", FP soDll]
        `mplus` unchanged
   | Just [thing, thingVersion, _, way]
         <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
               filename
      = do haveThingVersion thing thingVersion
           return [FP "libHS", FP thing, FP "-", VersionOf thing,
                   FP way, FP ".a"]
        `mplus` unchanged
   | Just [thing, thingVersion, _]
         <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
               filename
      = do haveThingVersion thing thingVersion
           return [FP "HS", FP thing, FP "-", VersionOf thing, FP ".o"]
        `mplus` unchanged
   | Just [thing, thingVersion, _, thingHash]
         <- re ("^(.*)-" ++ versionRE ++ "-([0-9a-f]{32})\\.conf$")
               filename
      = do haveThingVersion thing thingVersion
           haveThingHash    thing thingHash
           return [FP thing, FP "-", VersionOf thing, FP "-", HashOf thing,
                   FP ".conf"]
        `mplus` unchanged
   | Just [thingVersion, _]
         <- re ("^mingw32-gcc-" ++ versionRE ++ "\\.exe$")
               filename
      = do haveThingVersion "gcc" thingVersion
           return [FP "mingw32-gcc-", VersionOf "gcc", FP ".exe"]
        `mplus` unchanged
   | Just [dashedWays, depType]
         <- re "^\\.depend-(.*)\\.(haskell|c_asm)"
               filename
      = do mWays <- getMaybeWays
           if Just (unSepList '-' dashedWays) == mWays
               then return [FP ".depend-", Ways, FP ".", FP depType]
               else unchanged
   | otherwise = unchanged
      where unchanged = return [FP filename]
  
  compareContent :: Maybe Ways -> [(FilenameDescr, TarLine)]
                 -> Maybe Ways -> [(FilenameDescr, TarLine)]
                 -> [FileChange]
  compareContent mWays1 xs1all mWays2 xs2all
   = f xs1all xs2all
      where f [] [] = []
            f xs [] = concatMap (mkExtraFile mWays1 mWays2 First  . tlFileName . snd) xs
            f [] ys = concatMap (mkExtraFile mWays2 mWays1 Second . tlFileName . snd) ys
            f xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2')
             = case fd1 `compare` fd2 of
               EQ -> map Change (compareTarLine tl1 tl2)
                  ++ f xs1' xs2'
               LT -> mkExtraFile mWays1 mWays2 First  (tlFileName tl1)
                  ++ f xs1' xs2
               GT -> mkExtraFile mWays2 mWays1 Second (tlFileName tl2)
                  ++ f xs1 xs2'
            mkExtraFile mWaysMe mWaysThem mkFileChange filename
                = case (findFileWay filename, mWaysMe, mWaysThem) of
                  (Just way, Just waysMe, Just waysThem)
                   | (way `elem` waysMe) && not (way `elem` waysThem) -> []
                  _                  -> [mkFileChange (ExtraFile filename)]
  
  findFileWay :: FilePath -> Maybe String
  findFileWay fp
   | Just [way] <- re "\\.([a-z_]+)_hi$" fp
      = Just way
   | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp
      = Just way
   | otherwise = Nothing
  
  compareTarLine :: TarLine -> TarLine -> [Change]
  compareTarLine tl1 tl2
      = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ]
     ++ [ FileSizeChanged    fn1 fn2 size1  size2  | sizeChanged ]
      where fn1 = tlFileName tl1
            fn2 = tlFileName tl2
            perms1 = tlPermissions tl1
            perms2 = tlPermissions tl2
            size1 = tlSize tl1
            size2 = tlSize tl2
            sizeMin = size1 `min` size2
            sizeMax = size1 `max` size2
            sizeChanged = any sizeChangeThresholdReached sizeChangeThresholds
            sizeChangeThresholdReached (reqSize, percentage)
                = (sizeMax >= reqSize)
               && (((100 * sizeMax) `div` sizeMin) >= percentage)
  
  versionRE :: String
  versionRE = "([0-9]+(\\.[0-9]+)*)"
  
  