yi-0.5.2: Shim/ProjectContent.hs
--
-- 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