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

   1 module TreeDB(
   2     DirList,
   3     dlEmpty, dlByExt, dlByExts, dlAdd, dlAddByExt,
   4
   5     TreeDB,
   6     tdbEmpty, tdbByDir, tdbAdd, tdbAddDir,
   7     tdbBuild,
   8
   9     tdbByDirExt, tdbByDirExts
  10     )
  11 where
  12
  13 import qualified Data.ByteString.Char8 as C
  14 import Data.List
  15 import Data.Trie(Trie)
  16 import qualified Data.Trie as T
  17 import Data.Typeable
  18
  19 import System.FilePath
  20
  21 --
  22 -- The files in a directory, partitioned by extension.
  23 --
  24 type DirList = [(String, [String])]
  25
  26 dlEmpty :: DirList
  27 dlEmpty = []
  28
  29 -- Linear search for files by extension, in a single directory.
  30 dlByExt :: String -> DirList -> [String]
  31 dlByExt _ [] = []
  32 dlByExt ext ((ext', names) : dirlist)
  33     | ext' == ext = [n <.> ext' | n <- names]
  34     | otherwise = dlByExt ext dirlist
  35
  36 -- Search for multiple extensions at once.  'exts' must be sorted, with no
  37 -- duplicates.
  38 dlByExts :: [String] -> DirList -> [String]
  39 dlByExts _ [] = []
  40 dlByExts [] _ = []
  41 dlByExts (ext:exts) ((ext', names):dirlist) =
  42     case compare ext ext' of
  43         -- 'ext' isn't in the list.
  44         LT -> dlByExts exts ((ext', names):dirlist)
  45         -- 'ext' is right here.
  46         EQ -> [n <.> ext' | n <- names] ++ dlByExts exts dirlist
  47         -- 'ext' may be in the remainder.  Nothing else can match here.
  48         GT -> dlByExts (ext:exts) dirlist
  49
  50 -- Insert a file, given its extension.  Again linear.
  51 dlAdd :: FilePath -> DirList -> DirList
  52 dlAdd file dirList =
  53     dlAddByExt (takeExtension file) (dropExtension file) dirList
  54
  55 -- Keeps the list sorted by extension
  56 dlAddByExt ::  String -> String -> DirList -> DirList
  57 dlAddByExt ext name [] = [(ext, [name])]
  58 dlAddByExt ext name ((ext', names):dirlist) =
  59     case compare ext ext' of
  60         LT -> (ext, [name]):(ext', names):dirlist
  61         EQ -> (ext', name:names):dirlist
  62         GT -> (ext', names):(dlAddByExt ext name dirlist)
  63
  64 --
  65 -- A map from directory to contents, excluding subdirectories.
  66 --
  67 type TreeDB = Trie DirList
  68
  69 deriving instance Typeable1 Trie
  70
  71 tdbEmpty :: TreeDB
  72 tdbEmpty  = T.empty
  73
  74 -- Get directory contents by directory path
  75 tdbByDir :: FilePath -> TreeDB -> Maybe DirList
  76 tdbByDir path treeDB = T.lookup (C.pack path) treeDB
  77
  78 -- Add a file
  79 tdbAdd :: FilePath -> TreeDB -> TreeDB
  80 tdbAdd path treeDB
  81     | T.member dirS treeDB =
  82         T.adjust (\dirList -> dlAdd file dirList) dirS treeDB
  83     | otherwise =
  84         T.insert dirS (dlAdd file dlEmpty) treeDB
  85     where
  86         dir = takeDirectory path
  87         file = takeFileName path
  88         dirS = C.pack dir
  89
  90 -- Add a directory, complete with (relative) contents
  91 tdbAddDir :: FilePath -> [FilePath] -> TreeDB -> TreeDB
  92 tdbAddDir dir files treeDB
  93     | T.member dirS treeDB =
  94         T.adjust (\dirList -> foldr dlAdd dirList files) dirS treeDB
  95     | otherwise =
  96         T.insert dirS (foldr dlAdd dlEmpty files) treeDB
  97     where
  98         dirS = C.pack dir
  99
 100 tdbBuild :: [FilePath] -> TreeDB
 101 tdbBuild files = foldr tdbAdd tdbEmpty files
 102
 103 --
 104 -- Combined queries
 105 --
 106
 107 -- Find files by directory and extension
 108 tdbByDirExt :: FilePath -> String -> TreeDB -> Maybe [FilePath]
 109 tdbByDirExt path ext treeDB = do
 110     dirList <- tdbByDir path treeDB
 111     let filenames = dlByExt ext dirList
 112     return [ path </> file | file <- filenames ]
 113
 114 -- Look for multiple extensions.  'exts' need not be sorted.
 115 tdbByDirExts :: FilePath -> [String] -> TreeDB -> Maybe [FilePath]
 116 tdbByDirExts path exts treeDB = do
 117     dirList <- tdbByDir path treeDB
 118     let filenames = dlByExts (sort exts) dirList
 119     return [ path </> file | file <- filenames ]