module HsDev.Database (
Database(..),
databaseIntersection, nullDatabase, databaseLocals, allModules, allDeclarations,
fromModule, fromProject,
filterDB,
projectDB, cabalDB, standaloneDB,
selectModules, selectDeclarations, lookupModule, lookupFile, refineProject,
getInspected,
append, remove,
Structured(..),
structured, structurize, merge
) where
import Control.Applicative
import Control.Monad (msum, join)
import Control.DeepSeq (NFData(..))
import Data.Aeson
import Data.Either (rights)
import Data.Function (on)
import Data.Group (Group(..))
import Data.List (nub)
import Data.Map (Map)
import Data.Maybe
import Data.Monoid (Monoid(..))
import qualified Data.Map as M
import HsDev.Symbols
import HsDev.Symbols.Util
import HsDev.Project
import HsDev.Util ((.::))
data Database = Database {
databaseModules :: Map ModuleLocation InspectedModule,
databaseProjects :: Map FilePath Project }
deriving (Eq, Ord)
instance NFData Database where
rnf (Database ms ps) = rnf ms `seq` rnf ps
instance Group Database where
add old new = Database {
databaseModules = databaseModules new `M.union` databaseModules old,
databaseProjects = M.unionWith mergeProject (databaseProjects new) (databaseProjects old) }
where
mergeProject pl pr = pl {
projectDescription = msum [projectDescription pl, projectDescription pr] }
sub old new = Database {
databaseModules = databaseModules old `M.difference` databaseModules new,
databaseProjects = databaseProjects old `M.difference` databaseProjects new }
zero = Database M.empty M.empty
instance Monoid Database where
mempty = zero
mappend = add
instance ToJSON Database where
toJSON (Database ms ps) = object [
"modules" .= M.elems ms,
"projects" .= M.elems ps]
instance FromJSON Database where
parseJSON = withObject "database" $ \v -> Database <$>
((M.unions . map mkModule) <$> v .:: "modules") <*>
((M.unions . map mkProject) <$> v .:: "projects")
where
mkModule m = M.singleton (inspectedId m) m
mkProject p = M.singleton (projectCabal p) p
databaseIntersection :: Database -> Database -> Database
databaseIntersection l r = mempty {
databaseModules = databaseModules l `M.intersection` databaseModules r,
databaseProjects = databaseProjects l `M.intersection` databaseProjects r }
nullDatabase :: Database -> Bool
nullDatabase db = M.null (databaseModules db) && M.null (databaseProjects db)
databaseLocals :: Database -> Database
databaseLocals db = db {
databaseModules = M.map (fmap moduleLocals) (databaseModules db) }
allModules :: Database -> [Module]
allModules = rights . map inspectionResult . M.elems . databaseModules
allDeclarations :: Database -> [ModuleDeclaration]
allDeclarations db = do
m <- allModules db
moduleModuleDeclarations m
fromModule :: InspectedModule -> Database
fromModule m = zero {
databaseModules = M.singleton (inspectedId m) m }
fromProject :: Project -> Database
fromProject p = zero {
databaseProjects = M.singleton (projectCabal p) p }
filterDB :: (ModuleId -> Bool) -> (Project -> Bool) -> Database -> Database
filterDB m p db = mempty {
databaseModules = M.filter (either (const False) (m . moduleId) . inspectionResult) (databaseModules db),
databaseProjects = M.filter p (databaseProjects db) }
projectDB :: Project -> Database -> Database
projectDB proj = filterDB (inProject proj) (((==) `on` projectCabal) proj)
cabalDB :: Cabal -> Database -> Database
cabalDB cabal = filterDB (inCabal cabal) (const False)
standaloneDB :: Database -> Database
standaloneDB db = filterDB (check') (const False) db where
check' m = standalone m && byFile m
selectModules :: (Module -> Bool) -> Database -> [Module]
selectModules p = filter p . allModules
selectDeclarations :: (ModuleDeclaration -> Bool) -> Database -> [ModuleDeclaration]
selectDeclarations p = filter p . allDeclarations
lookupModule :: ModuleLocation -> Database -> Maybe Module
lookupModule mloc db = do
m <- M.lookup mloc $ databaseModules db
either (const Nothing) Just $ inspectionResult m
lookupFile :: FilePath -> Database -> Maybe Module
lookupFile f = listToMaybe . selectModules (inFile f . moduleId)
refineProject :: Database -> Project -> Maybe Project
refineProject db proj = M.lookup (projectCabal proj) $ databaseProjects db
getInspected :: Database -> Module -> InspectedModule
getInspected db m = fromMaybe err $ M.lookup (moduleLocation m) $ databaseModules db where
err = error "Impossible happened: getInspected"
append :: Database -> Database -> Database
append = add
remove :: Database -> Database -> Database
remove = sub
data Structured = Structured {
structuredCabals :: Map Cabal Database,
structuredProjects :: Map FilePath Database,
structuredFiles :: Database }
deriving (Eq, Ord)
instance NFData Structured where
rnf (Structured cs ps fs) = rnf cs `seq` rnf ps `seq` rnf fs
instance Group Structured where
add old new = Structured {
structuredCabals = structuredCabals new `M.union` structuredCabals old,
structuredProjects = structuredProjects new `M.union` structuredProjects old,
structuredFiles = structuredFiles old `add` structuredFiles new }
sub old new = Structured {
structuredCabals = structuredCabals old `M.difference` structuredCabals new,
structuredProjects = structuredProjects old `M.difference` structuredProjects new,
structuredFiles = structuredFiles old `sub` structuredFiles new }
zero = Structured zero zero zero
instance Monoid Structured where
mempty = zero
mappend = add
instance ToJSON Structured where
toJSON (Structured cs ps fs) = object [
"cabals" .= M.elems cs,
"projects" .= M.elems ps,
"files" .= fs]
instance FromJSON Structured where
parseJSON = withObject "structured" $ \v -> join $
either fail return <$> (structured <$>
(v .:: "cabals") <*>
(v .:: "projects") <*>
(v .:: "files"))
structured :: [Database] -> [Database] -> Database -> Either String Structured
structured cs ps fs = Structured <$> mkMap keyCabal cs <*> mkMap keyProj ps <*> pure fs where
mkMap :: Ord a => (Database -> Either String a) -> [Database] -> Either String (Map a Database)
mkMap key dbs = do
keys <- mapM key dbs
return $ M.fromList $ zip keys dbs
keyCabal :: Database -> Either String Cabal
keyCabal db = unique
"No cabal"
"Different module cabals"
(nub <$> mapM getCabal (allModules db))
where
getCabal m = case moduleLocation m of
CabalModule c _ _ -> Right c
_ -> Left "Module have no cabal"
keyProj :: Database -> Either String FilePath
keyProj db = unique
"No project"
"Different module projects"
(return (M.keys (databaseProjects db)))
unique :: (Eq a) => String -> String -> Either String [a] -> Either String a
unique _ _ (Left e) = Left e
unique no _ (Right []) = Left no
unique _ _ (Right [x]) = Right x
unique _ much (Right _) = Left much
structurize :: Database -> Structured
structurize db = Structured cs ps fs where
cs = M.fromList [(c, cabalDB c db) | c <- nub (mapMaybe modCabal (allModules db))]
ps = M.fromList [(pname, projectDB (project pname) db) | pname <- M.keys (databaseProjects db)]
fs = standaloneDB db
merge :: Structured -> Database
merge (Structured cs ps fs) = mconcat $ M.elems cs ++ M.elems ps ++ [fs]
modCabal :: Module -> Maybe Cabal
modCabal m = case moduleLocation m of
CabalModule c _ _ -> Just c
_ -> Nothing