{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Module that contains high-level checking for an entire directory
{-# LANGUAGE TupleSections     #-}
module CheckDir (recursiveCheckDir)  where

import           CheckMap              (MapResult (mapresultProvides),
                                        loadAndLintMap, mapresultDepends)
import           Control.Monad         (void)
import           Data.Aeson            (ToJSON, (.=))
import qualified Data.Aeson            as A
import           Data.Bifunctor        (bimap)
import           Data.Foldable         (fold)
import           Data.Functor          ((<&>))
import           Data.Map              (Map)
import qualified Data.Map              as M
import           Data.Map.Strict       (mapKeys, (\\))
import           Data.Maybe            (mapMaybe)
import           Data.Text             (Text)
import qualified Data.Text             as T
import           GHC.Generics          (Generic)
import           Paths                 (normalise, normaliseWithFrag)
import           System.FilePath       (splitPath, (</>))
import qualified System.FilePath       as FP
import           System.FilePath.Posix (takeDirectory)
import           Types                 (Dep (LocalMap), Level)
import           Util                  (PrettyPrint (prettyprint))

-- based on the startling observation that Data.Map has lower complexity
-- for difference than Data.Set, but the same complexity for fromList
type Set a = Map a ()
setFromList :: Ord a => [a] -> Set a
setFromList  = M.fromList . flip zip (repeat ())
listFromSet :: Set a -> [a]
listFromSet = map fst . M.toList

-- | Result of linting an entire directory / repository
data DirResult = DirResult
  { dirresultMaps :: Map FilePath MapResult
  , dirresultDeps :: [MissingDep]
  } deriving (Generic)

data MissingDep = MissingDep
  { entrypoint :: Text
  , neededBy   :: [FilePath]
  } deriving (Generic, ToJSON)

instance ToJSON DirResult where
  toJSON res = A.object
    [ "missingDeps" .= dirresultDeps res
    , "mapLints" .= dirresultMaps res
    ]

instance PrettyPrint (Level, DirResult) where
  prettyprint (level, res) = prettyMapLints <> prettyMissingDeps
    where
      prettyMissingDeps = if not (null (dirresultDeps res))
        then "\nDependency Errors:\n" <> foldMap prettyprint (dirresultDeps res)
        else ""
      prettyMapLints = T.concat
        (map prettyLint $ M.toList $ dirresultMaps res)
      prettyLint :: (FilePath, MapResult) -> Text
      prettyLint (p, lint) =
        "\nin " <> T.pack p <> ":\n" <> prettyprint (level, lint)

instance PrettyPrint MissingDep where
  prettyprint (MissingDep f n) =
    "  - " <> f <> " does not exist, but is required by "
    <> prettyDependents <> "\n"
    where
      prettyDependents =
        T.intercalate "," $ map T.pack n


instance Semigroup DirResult where
  a <> b = DirResult
    { dirresultMaps = dirresultMaps a <> dirresultMaps b
    , dirresultDeps = dirresultDeps a <> dirresultDeps b
    }

instance Monoid DirResult where
  mempty = DirResult
    { dirresultMaps = mempty
    , dirresultDeps = []
    }


-- | The nice function to check an entire repository with.
-- gets a prefix (i.e. the bare path to the repository) and
-- a root (i.e. the name of the file containing the entrypoint
-- map within that file)
recursiveCheckDir :: FilePath -> FilePath -> IO DirResult
recursiveCheckDir prefix root = do
  linted <- recursiveCheckDir' prefix [root] mempty mempty
  pure $ linted <> mempty { dirresultDeps = missingDeps linted }


-- | Given a (partially) completed DirResult, check which local
-- maps are referenced but do not actually exist.
missingDeps :: DirResult -> [MissingDep]
missingDeps res =
  let simple = used \\ M.union defined trivial
  in M.foldMapWithKey (\f n -> [MissingDep f n]) simple
  where
    -- which maps are linked somewhere?
    used :: Map Text [FilePath]
    used = M.fromList
      $ M.foldMapWithKey
      (\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v)
      (dirresultMaps res)
      where extractLocalDeps prefix = \case
              LocalMap name -> Just $ T.pack $ normaliseWithFrag prefix name
              _             -> Nothing
    -- which are defined using startLayer?
    defined :: Set Text
    defined = setFromList
      $ M.foldMapWithKey
      (\k v -> map ((T.pack k <> "#") <>) . mapresultProvides $ v)
      (dirresultMaps res)
    -- each map file is an entrypoint by itself
    trivial = mapKeys T.pack $ void (dirresultMaps res)


-- | The less-nice function for checking an entire repository.
--
-- Strictly speaking it probably doesn't need to have `done` and
-- `acc` since they are essentially the same thing, but doing it
-- like this seemed convenient at the time
recursiveCheckDir' :: FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult
recursiveCheckDir' prefix paths done acc = do

  -- lint all maps in paths
  lints <-
    let lintPath p = loadAndLintMap (prefix </> p) depth <&> (p,)
          where depth = length (splitPath p) - 1
    in mapM lintPath paths


  let mapdeps = concatMap
       (\(m,res) ->
          let ps = mapMaybe
                (\case {LocalMap p -> Just p; _ -> Nothing})
                (mapresultDepends res)
          in map (FP.normalise . normalise (takeDirectory m)) ps
       )
       lints

  -- build a Set containing all newly found dependencies, with paths
  -- from the repository's directory, normalised not to start with ./ etc.
  let setdeps = setFromList
       mapdeps
  -- that which is yet to do (O(m+n))
  let unknowns = listFromSet $ M.difference setdeps done
  -- that which is done
  let knowns = M.union done $ setFromList paths

  -- Monoids!
  let acc' = acc <> DirResult
                { dirresultMaps = M.fromList lints
                , dirresultDeps = [] }
  -- Tail recursion!
  case unknowns of
    [] -> pure acc'
    _  -> recursiveCheckDir' prefix unknowns knowns acc'