git.barrelfish.org Git - barrelfish/blob - hake/TreeDB.hs

   1 module TreeDB(
   2     DirList,
   3     dlEmpty, dlByExt, dlAdd, dlAddByExt,
   4
   5     TreeDB,
   6     tdbEmpty, tdbByDir, tdbAdd, tdbAddDir,
   7     tdbBuild,
   8
   9     tdbByDirExt
  10     )
  11 where
  12
  13 import qualified Data.ByteString.Char8 as C
  14 import Data.Trie(Trie)
  15 import qualified Data.Trie as T
  16 import Data.Typeable
  17
  18 import System.FilePath
  19
  20 --
  21 -- The files in a directory, partitioned by extension.
  22 --
  23 type DirList = [(String, [String])]
  24
  25 dlEmpty :: DirList
  26 dlEmpty = []
  27
  28 -- Linear search for files by extension, in a single directory.
  29 dlByExt :: String -> DirList -> [String]
  30 dlByExt _ [] = []
  31 dlByExt ext ((ext', names) : dirlist)
  32     | ext == ext' = names
  33     | otherwise = dlByExt ext dirlist
  34
  35 -- Insert a file, given its extension.  Again linear.
  36 dlAdd :: FilePath -> DirList -> DirList
  37 dlAdd file dirList =
  38     dlAddByExt (takeExtension file) (dropExtension file) dirList
  39
  40 dlAddByExt ::  String -> String -> DirList -> DirList
  41 dlAddByExt ext name [] = [(ext, [name])]
  42 dlAddByExt ext name ((ext', names):dirlist)
  43     | ext == ext' = (ext', name:names):dirlist
  44     | otherwise = (ext', names):(dlAddByExt ext name dirlist)
  45
  46 --
  47 -- A map from directory to contents, excluding subdirectories.
  48 --
  49 type TreeDB = Trie DirList
  50
  51 deriving instance Typeable1 Trie
  52
  53 tdbEmpty :: TreeDB
  54 tdbEmpty  = T.empty
  55
  56 -- Get directory contents by directory path
  57 tdbByDir :: FilePath -> TreeDB -> Maybe DirList
  58 tdbByDir path treeDB = T.lookup (C.pack path) treeDB
  59
  60 -- Add a file
  61 tdbAdd :: FilePath -> TreeDB -> TreeDB
  62 tdbAdd path treeDB
  63     | T.member dirS treeDB =
  64         T.adjust (\dirList -> dlAdd file dirList) dirS treeDB
  65     | otherwise =
  66         T.insert dirS (dlAdd file dlEmpty) treeDB
  67     where
  68         dir = takeDirectory path
  69         file = takeFileName path
  70         dirS = C.pack dir
  71
  72 -- Add a directory, complete with (relative) contents
  73 tdbAddDir :: FilePath -> [FilePath] -> TreeDB -> TreeDB
  74 tdbAddDir dir files treeDB
  75     | T.member dirS treeDB =
  76         T.adjust (\dirList -> foldr dlAdd dirList files) dirS treeDB
  77     | otherwise =
  78         T.insert dirS (foldr dlAdd dlEmpty files) treeDB
  79     where
  80         dirS = C.pack dir
  81
  82 tdbBuild :: [FilePath] -> TreeDB
  83 tdbBuild files = foldr tdbAdd tdbEmpty files
  84
  85 --
  86 -- Combined queries
  87 --
  88
  89 -- Find files by directory and extension
  90 tdbByDirExt :: FilePath -> String -> TreeDB -> Maybe [FilePath]
  91 tdbByDirExt path ext treeDB = do
  92     dirList <- tdbByDir path treeDB
  93     let basenames = dlByExt ext dirList
  94     return [ path </> base <.> ext | base <- basenames ]