yi-0.6.4.0: src/library/Shim/ProjectContent.hs
{-# LANGUAGE Rank2Types #-}
-- Copyright (c) Krasimir Angelov 2008.
--
-- Extraction of the "Project View" from
-- already configured Cabal package.
--
-- TODO: much of this module was commented out to avoid 'defined but not used' warnings. The commented functions should either be exported or removed.
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 Distribution.PackageDescription
import Distribution.Simple.Utils(findFileWithExtension')
import Distribution.Simple.PreProcess(knownSuffixHandlers)
import System.FilePath
import System.Directory
-}
import Distribution.ModuleName
import Distribution.Version
import Distribution.Package
import Distribution.Text
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 :: FilePath
-> (Set.Set ProjectItem, TreeLoc ProjectItem)
-> Library
-> IO (Set.Set ProjectItem, TreeLoc ProjectItem)
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 :: FilePath
-> (Set.Set ProjectItem, TreeLoc ProjectItem)
-> Executable
-> IO (Set.Set ProjectItem, TreeLoc ProjectItem)
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 :: [PackageIdentifier] -> State (TreeLoc ProjectItem) ()
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' _ [] 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 :: a -> Tree a
simpleNode item = Node item []
splitPath' :: FilePath -> [String]
splitPath' fpath = [removeSlash c | c <- splitPath fpath]
where
removeSlash c
| null c = c
| isPathSeparator (last c) = init c
| otherwise = c
checkAndAddFile :: FilePath -> FilePath -> FileKind -> TreeLoc ProjectItem -> IO (TreeLoc ProjectItem)
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 _ [] = 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
-}