{-# LANGUAGE Rank2Types #-}
-- Copyright (c) Krasimir Angelov 2008.
--
-- Extraction of the "Project View" from
-- already configured Cabal package.
--

module Shim.ProjectContent
         ( {- loadProject
         , -} itemName
         , ProjectItem(..)
         , FileKind(..)
         , FolderKind(..)
         , ModuleKind(..)
         ) where

import Control.Monad.State
import Data.Tree
import Data.Tree.Zipper
import qualified Data.Set as Set
import Data.List (partition)
import Distribution.ModuleName
import Distribution.Version
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Configure
import Distribution.Simple.Utils(findFileWithExtension')
import Distribution.Simple.PreProcess(knownSuffixHandlers)
import Distribution.Simple.Setup (defaultDistPref)
import Distribution.Text
import System.FilePath
import System.Directory

data ProjectItem
  = ProjectItem
      { projItemName :: String
      , itemVersion :: Version
      }
  | DependenciesItem 
      { depItemName   :: String
      }
  | FolderItem 
      { folderItemName   :: String
      , folderKind :: FolderKind
      }
  | FileItem
      { fileItemName   :: String
      , itemFPath  :: FilePath
      , fileKind   :: FileKind
      }
  | PackageItem
      { pkgItemName   :: PackageName
      , itemVersion:: Version
      }
  | ModuleItem
      { modItemName   :: ModuleName
      , itemFPath  :: FilePath
      , moduleKind :: ModuleKind
      }
  deriving (Eq, Ord, Show)

itemName :: ProjectItem -> String
itemName ProjectItem {projItemName = n} = n
itemName DependenciesItem {depItemName = n} = n
itemName FolderItem {folderItemName = n} = n
itemName FileItem {fileItemName = n} = n
itemName PackageItem {pkgItemName = p} = display p
itemName ModuleItem {modItemName = m} = display m



data FileKind
  = HsSource ModuleKind
  | CSource
  | HSource
  | TextFile
  | SetupScript
  | LicenseText
  deriving (Eq, Ord, Show)

data FolderKind
  = HsSourceFolder
  | PlainFolder
  deriving (Eq, Ord, Show)

data ModuleKind
  = ExposedModule
  | HiddenModule
  deriving (Eq, Ord, Show)

{-
loadProject :: FilePath -> IO (Tree ProjectItem, Tree ProjectItem)
loadProject projPath = do
  Right lbi <- tryGetConfigStateFile (projPath </> localBuildInfoFile defaultDistPref)
  let pkgDescr = localPkgDescr lbi

      root  = PackageItem (pkgName (package pkgDescr)) (pkgVersion (package pkgDescr))
      tloc1 = execState (addDependenciesTree (packageDeps lbi)) (getTop (Node root []))
  (mod_items,tloc2) <- case library pkgDescr of
             Just lib -> addLibraryTree projPath (Set.empty,tloc1) lib
             Nothing  -> return (Set.empty,tloc1)
  (mod_items,tloc2) <- foldM (addExecutableTree projPath) (mod_items,tloc2) (executables pkgDescr)
  tloc3 <- checkAndAddFile projPath "Setup.hs"  SetupScript tloc2
  tloc4 <- checkAndAddFile projPath "Setup.lhs" SetupScript tloc3
  let (hsources,extra_sources) = partition (\fpath -> takeExtension fpath == ".h") (extraSrcFiles pkgDescr)
      tloc5 = execState (do mapM_ (addFilePath HSource  projPath)  hsources
                            mapM_ (addFilePath TextFile projPath) extra_sources
                            mapM_ (addFilePath TextFile projPath) (dataFiles pkgDescr)
                            addFilePath LicenseText projPath (licenseFile pkgDescr)) tloc4
      tloc6 = execState (mapM_ (\item -> insertDown item >> up) (Set.toList mod_items)) tloc1
  return (tree tloc5, tree tloc6)
-}

getTop :: Tree a -> TreeLoc a
getTop = fromTree

insertDown :: forall a. a -> State (TreeLoc a) ()
insertDown label = modify (insertDownLast $ Node label [])

up :: State (TreeLoc a) ()
up = modify' parent

modify' :: (a -> Maybe a) -> State a ()
modify' f = modify (\x -> maybe (error "impossible movement!") id (f x))


addLibraryTree projPath (mod_items,tloc) (Library {libBuildInfo=binfo, exposedModules=exp_mods}) = do
  (exp_mods,hid_mods,mod_items1,tloc1) <- foldM (\st dir -> addSourceDir projPath dir st)
                                                (exp_mods,otherModules binfo,mod_items,tloc)
                                                (hsSourceDirs binfo)
  return $ (mod_items1,execState (mapM_ (addFilePath CSource projPath) (cSources binfo)) tloc1)
  
addExecutableTree projPath (mod_items,tloc) (Executable {modulePath=mainIs, buildInfo=binfo}) = do
  let tloc1 = execState (addFilePath (HsSource ExposedModule) projPath mainIs) tloc
  (exp_mods,hid_mods,mod_items2,tloc2) <- foldM (\st dir -> addSourceDir projPath dir st)
                                                ([],otherModules binfo,mod_items,tloc1)
                                                (hsSourceDirs binfo)
  return $ (mod_items2,execState (mapM_ (addFilePath CSource projPath) (cSources binfo)) tloc2)

addDependenciesTree deps = do
  insertDown (DependenciesItem "Dependencies")
  mapM_ addDependency deps
  up
  where
    addDependency dep = do
      insertDown (PackageItem (pkgName dep) (pkgVersion dep))
      up

addSourceDir :: FilePath -- ^ project location
             -> FilePath -- ^ source sub-directory
             ->    ([ModuleName],[ModuleName],Set.Set ProjectItem,TreeLoc ProjectItem)
             -> IO ([ModuleName],[ModuleName],Set.Set ProjectItem,TreeLoc ProjectItem)
addSourceDir projPath srcDir (exp_mods,hid_mods,mod_items,tloc) = do
  let dir = projPath </> srcDir
  (exp_paths,exp_mods) <- findModules dir exp_mods
  (hid_paths,hid_mods) <- findModules dir hid_mods
  let tloc1 = execState (addFilePath' (\c -> FolderItem c HsSourceFolder) (splitPath' srcDir)
                            (mapM_ (\(mod,loc) -> addFilePath (HsSource ExposedModule) dir loc) exp_paths >>
                             mapM_ (\(mod,loc) -> addFilePath (HsSource HiddenModule)  dir loc) hid_paths))
                        tloc
      mod_items1 = foldr (\(mod,loc) -> Set.insert (ModuleItem mod (dir </> loc) ExposedModule)) mod_items  exp_paths
      mod_items2 = foldr (\(mod,loc) -> Set.insert (ModuleItem mod (dir </> loc) HiddenModule )) mod_items1 hid_paths
  return (exp_mods,hid_mods,mod_items2,tloc1)

addFilePath :: FileKind -> FilePath -> FilePath -> State (TreeLoc ProjectItem) ()
addFilePath kind root fpath = addFilePath' (\c -> FileItem c (root </> fpath) kind) (splitPath' fpath) (return ())

addFilePath' :: (String -> ProjectItem) -> [String] 
             -> State (TreeLoc ProjectItem) ()
             -> State (TreeLoc ProjectItem) ()
addFilePath' mkItem []     cont = cont
addFilePath' mkItem (c:cs) cont
  | c == "."  = addFilePath' mkItem cs cont
  | otherwise = do let item | null cs   = mkItem c
                            | otherwise = FolderItem c PlainFolder
                   children <- gets hasChildren
                   if children
                     then modify' firstChild >> insertItem c item
                     else insertDown item
                   addFilePath' mkItem cs cont
                   up >> return ()
  where
    insertItem :: Ord a => x -> a -> State (TreeLoc a) ()
    insertItem c item = do
      item' <- gets getLabel
      case compare item item' of
        LT -> modify $ insertLeft $ simpleNode item
        EQ -> return ()
        GT -> do last <- gets isLast
                 if last
                   then modify $ insertRight $ simpleNode item
                   else modify' right >> insertItem c item

simpleNode item = Node item []

splitPath' fpath = [removeSlash c | c <- splitPath fpath]
  where
    removeSlash c
      | null c                   = c
      | isPathSeparator (last c) = init c
      | otherwise                = c

checkAndAddFile projPath fpath kind tloc = do
  let fullPath = projPath </> fpath
  exists <- doesFileExist fullPath
  if exists
    then return $ execState (addFilePath kind fullPath fpath) tloc
    else return tloc

-------------------------------------------------------------------------
-- Module Finder
-------------------------------------------------------------------------

findModules :: FilePath                           -- ^source directory location
            -> [ModuleName]                           -- ^module names
            -> IO ([(ModuleName,FilePath)],[ModuleName])  -- ^found modules and unknown modules
findModules location []         = return ([],[])
findModules location (mod:mods) = do
  mb_paths <- findFileWithExtension' (map fst knownSuffixHandlers ++ ["hs", "lhs"]) [location] (toFilePath mod)
  (locs,unks) <- findModules location mods
  case mb_paths of
    Just (_,loc) -> return ((mod,loc) : locs,unks)
    Nothing      -> return (locs,mod:unks)

findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a)
findFirstFile file = findFirst
  where findFirst []     = return Nothing
        findFirst (x:xs) = do exists <- doesFileExist (file x)
                              if exists
                                then return (Just x)
                                else findFirst xs