diff --git a/lib/Proteome/Config.hs b/lib/Proteome/Config.hs --- a/lib/Proteome/Config.hs +++ b/lib/Proteome/Config.hs @@ -40,7 +40,8 @@ ProjectConfig { projectTypes :: Map ProjectType [FilePath], typeMap :: Map ProjectType [ProjectType], - langMap :: Map ProjectType [ProjectLang] + langMap :: Map ProjectType ProjectLang, + langsMap :: Map ProjectLang [ProjectLang] } deriving (Generic, NFData) @@ -49,13 +50,16 @@ (toObject :: Dictionary -> Object) . Map.fromList $ [ ("projectTypes", toObject projectTypes), - ("typeMap", toObject typeMap) + ("typeMap", toObject typeMap), + ("langMap", toObject langMap), + ("langsMap", toObject langsMap) ] fromObject (ObjectMap o) = do projectTypes' <- extractObject "projectTypes" o typeMap' <- extractObject "typeMap" o langMap' <- extractObject "langMap" o - return $ ProjectConfig projectTypes' typeMap' langMap' + langsMap' <- extractObject "langsMap" o + return $ ProjectConfig projectTypes' typeMap' langMap' langsMap' fromObject o = Left ("invalid type for ProjectConfig: " <+> viaShow o) globRtp :: FilePath -> Ribo a [FilePath] diff --git a/lib/Proteome/Data/Project.hs b/lib/Proteome/Data/Project.hs --- a/lib/Proteome/Data/Project.hs +++ b/lib/Proteome/Data/Project.hs @@ -43,7 +43,7 @@ { projectLang :: String } - deriving (Eq, Show, Generic, NFData) + deriving (Ord, Eq, Show, Generic, NFData) instance NvimObject ProjectLang where toObject (ProjectLang s) = toObject s diff --git a/lib/Proteome/Diag.hs b/lib/Proteome/Diag.hs --- a/lib/Proteome/Diag.hs +++ b/lib/Proteome/Diag.hs @@ -4,12 +4,14 @@ import Data.Functor (void) import Data.List (intercalate) +import Data.Map (foldMapWithKey) import Neovim (CommandArguments) import Ribosome.Data.ScratchOptions (defaultScratchOptions) +import Ribosome.Data.Errors (Error(Error), Errors(Errors), ComponentName(ComponentName)) import Ribosome.Scratch (showInScratch) import qualified Ribosome.Data.Ribo as Ribo (inspect) import Proteome.Env (getMainProject) -import Proteome.Data.Env(configLog) +import qualified Proteome.Data.Env as Env (configLog, projects, errors) import Proteome.Data.Proteome (Proteome) import Proteome.Data.Project ( Project (Project), @@ -49,11 +51,44 @@ "languages: " ++ intercalate ", " (fmap projectLang langs) ] +formatExtraProjects :: [Project] -> Proteome [String] +formatExtraProjects projects = do + formatted <- traverse formatMain projects + return $ ["", "Extra projects", ""] ++ intercalate [""] formatted + +formatExtraProjectsIfNonempty :: Proteome [String] +formatExtraProjectsIfNonempty = do + projects <- Ribo.inspect Env.projects + case projects of + _ : _ -> formatExtraProjects projects + _ -> return [] + +formatError :: Error -> [String] +formatError (Error stamp (first:message)) = (show stamp ++ " | " ++ first) : message +formatError _ = [] + +formatComponentErrors :: ComponentName -> [Error] -> [String] +formatComponentErrors (ComponentName name) errors@(_ : _) = + [name ++ "", ""] ++ (errors >>= formatError) +formatComponentErrors _ _ = [] + + +formatErrorLog :: Errors -> [String] +formatErrorLog (Errors errors) = + case compErrors of + _ : _ -> ["", "Errors", ""] ++ compErrors + _ -> [] + where + compErrors = foldMapWithKey formatComponentErrors errors + diagnostics :: Proteome [String] diagnostics = do main <- getMainProject >>= formatMain - confLog <- Ribo.inspect $ configLog - return $ ["Diagnostics", "", "Main project:"] ++ main ++ ["", "loaded config files:"] ++ confLog + extra <- formatExtraProjectsIfNonempty + confLog <- Ribo.inspect Env.configLog + errors <- Ribo.inspect Env.errors + return $ ["Diagnostics", "", "Main project", ""] ++ main ++ extra ++ ["", "loaded config files:"] ++ + confLog ++ formatErrorLog errors proDiag :: CommandArguments -> Proteome () proDiag _ = do diff --git a/lib/Proteome/Project/Resolve.hs b/lib/Proteome/Project/Resolve.hs --- a/lib/Proteome/Project/Resolve.hs +++ b/lib/Proteome/Project/Resolve.hs @@ -37,7 +37,7 @@ projectFromSegments :: ProjectType -> ProjectName -> ProjectRoot -> Project projectFromSegments tpe name root = - Project (DirProject name root (Just tpe)) [] (Just (ProjectLang (projectType tpe))) [] + Project (DirProject name root (Just tpe)) [] Nothing [] projectFromSpec :: ProjectSpec -> Project projectFromSpec (ProjectSpec name root tpe types lang langs) = @@ -105,23 +105,31 @@ where byRoot = find (hasProjectRoot root) explicit -augment :: Eq a => Map ProjectType [a] -> ProjectType -> [a] -> [a] +augment :: (Eq a, Ord k) => Map k [a] -> k -> [a] -> [a] augment m tpe as = case m !? tpe of Just extra -> uniq $ as ++ extra Nothing -> as augmentTypes :: ProjectConfig -> ProjectType -> [ProjectType] -> [ProjectType] -augmentTypes (ProjectConfig _ typeMap _) = +augmentTypes (ProjectConfig _ typeMap _ _) = augment typeMap -augmentLangs :: ProjectConfig -> ProjectType -> [ProjectLang] -> [ProjectLang] -augmentLangs (ProjectConfig _ _ langMap) = - augment langMap +realLang :: ProjectConfig -> ProjectType -> ProjectLang +realLang (ProjectConfig _ _ langMap _) t@(ProjectType tpe) = + case langMap !? t of + Just real -> real + Nothing -> (ProjectLang tpe) +augmentLangs :: ProjectConfig -> ProjectLang -> [ProjectLang] -> [ProjectLang] +augmentLangs (ProjectConfig _ _ _ langsMap) = + augment langsMap + augmentFromConfig :: ProjectConfig -> Project -> Project augmentFromConfig config (Project meta@(DirProject _ _ (Just tpe)) types lang langs) = - Project meta (augmentTypes config tpe types) lang (augmentLangs config tpe langs) + Project meta (augmentTypes config tpe types) (Just realLang') (augmentLangs config realLang' langs) + where + realLang' = fromMaybe (realLang config tpe) lang augmentFromConfig _ project = project resolveProject :: diff --git a/lib/Proteome/Settings.hs b/lib/Proteome/Settings.hs --- a/lib/Proteome/Settings.hs +++ b/lib/Proteome/Settings.hs @@ -33,7 +33,7 @@ projectTypeDirs = Setting "project_type_dirs" True (Just []) projectConfig :: Setting ProjectConfig -projectConfig = Setting "project_config" True (Just (ProjectConfig def def def)) +projectConfig = Setting "project_config" True (Just (ProjectConfig def def def def)) mainName :: Setting ProjectName mainName = Setting "main_name" True Nothing diff --git a/lib/Ribosome/Data/ScratchOptions.hs b/lib/Ribosome/Data/ScratchOptions.hs --- a/lib/Ribosome/Data/ScratchOptions.hs +++ b/lib/Ribosome/Data/ScratchOptions.hs @@ -13,4 +13,4 @@ } defaultScratchOptions :: String -> ScratchOptions -defaultScratchOptions = ScratchOptions False True Nothing False +defaultScratchOptions = ScratchOptions False False Nothing False diff --git a/lib/Ribosome/Internal/NvimObject.hs b/lib/Ribosome/Internal/NvimObject.hs --- a/lib/Ribosome/Internal/NvimObject.hs +++ b/lib/Ribosome/Internal/NvimObject.hs @@ -14,7 +14,7 @@ objectKeyMissing :: String -> Maybe Object -> Either (Doc AnsiStyle) Object objectKeyMissing _ (Just o) = Right o -objectKeyMissing key Nothing = Left (pretty "missing key in nvim data: " <+> pretty key) +objectKeyMissing key Nothing = Left (pretty "missing key in nvim data:" <+> pretty key) extractObject :: NvimObject o => String -> Map Object Object -> Either (Doc AnsiStyle) o extractObject key data' = do diff --git a/proteome.cabal b/proteome.cabal --- a/proteome.cabal +++ b/proteome.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 917213ba241750938131206d147b3973a904538143e66ce0c0bd23c6ef8474c7 +-- hash: a201573127715cdeead3c56a82e3910c0ee5aab091fb878f23ad264ffce76c4b name: proteome -version: 0.3.15.0 +version: 0.3.16.0 synopsis: neovim project manager description: Please see the README on GitHub at category: Neovim diff --git a/test/u/DiagSpec.hs b/test/u/DiagSpec.hs --- a/test/u/DiagSpec.hs +++ b/test/u/DiagSpec.hs @@ -35,7 +35,8 @@ target = [ "Diagnostics", "", - "Main project:", + "Main project", + "", "name: " ++ flag, "root: " ++ root, "type: " ++ hask, diff --git a/test/u/ResolveSpec.hs b/test/u/ResolveSpec.hs --- a/test/u/ResolveSpec.hs +++ b/test/u/ResolveSpec.hs @@ -4,6 +4,7 @@ htf_thisModulesTests ) where +import Data.Map.Strict (Map) import qualified Data.Map as Map (fromList) import Data.Default.Class (Default(def)) import Test.Framework @@ -54,8 +55,11 @@ lang2 :: ProjectLang lang2 = ProjectLang "agda" +typeMap :: Map ProjectType [ProjectType] +typeMap = Map.fromList [(tpe, [tpe1, tpe2])] + config :: ProjectConfig -config = ProjectConfig def (Map.fromList [(tpe, [tpe1, tpe2])]) (Map.fromList [(tpe, [lang1, lang2])]) +config = ProjectConfig def typeMap (Map.fromList [(tpe, lang)]) (Map.fromList [(lang, [lang1, lang2])]) targetProject :: Project targetProject = Project (DirProject name root (Just tpe)) [tpe1, tpe2] (Just lang) [lang1, lang2]