khph-0.1.0: src/Main.hs
-- This file is part of khph.
--
-- Copyright 2016 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP #-}
module Main (main) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad ((<=<), forM_, unless)
import Control.Monad.IO.Class (liftIO)
import Data.Either (partitionEithers)
import Data.List (intercalate, isSuffixOf)
import Data.Maybe (catMaybes, isNothing)
import qualified Data.Set as Set
import qualified Khph.Args as Args
import Khph.Project.Base
import qualified Khph.Project.Impl as ProjectImpl
import Khph.Project.Monad
import Khph.Query.Base
import Khph.Query.Parse
import Khph.Util
import System.Directory (
canonicalizePath,
getCurrentDirectory,
getDirectoryContents,
)
import System.Exit (exitFailure)
import System.FilePath (
(</>),
pathSeparator,
replaceBaseName,
takeBaseName,
takeDirectory,
takeFileName,
)
import System.IO (hPutStrLn, stderr)
import System.Posix.Files (getFileStatus, isDirectory, isRegularFile)
main :: IO ()
main = do
flagsResult <- Args.parseFlags
case flagsResult of
Left err -> do
hPutStrLn stderr $ "khph: " ++ err
exitFailure
Right (commonArgs, maybeRequest) -> do
initialDirectory <- canonicalizePath =<< getCurrentDirectory
-- Find a project file to use.
(projectRoot, maybeProjectFile) <- case Args.caProject commonArgs of
"" -> do
result <- findProjectFile True initialDirectory
case result of
Nothing -> die "Couldn't find a project."
Just path -> return (takeDirectory path, Just $ takeFileName path)
pathRaw -> do
path <- canonicalizePath pathRaw
stat <- getFileStatus path
case undefined of
_ | isRegularFile stat ->
return (takeDirectory path, Just $ takeFileName path)
_ | isDirectory stat -> do
maybeProjectFile <- findProjectFile False path
return (path, maybeProjectFile)
_ -> die $ concat
["--project expects a regular file or directory. Got ", show path, "."]
ProjectImpl.run commonArgs projectRoot maybeProjectFile $ do
request <- case maybeRequest of
Just request -> return request
Nothing -> liftIO $ do
putStr $ unlines
[ "khph: " ++ Args.description
, "See --help for more information."
]
exitFailure
case request of
Args.Help ->
-- Printing the help message is handled by the argument parser.
return ()
Args.List {Args.listQuery = queryStrMaybe} -> do
query <- case queryStrMaybe of
Nothing -> return LogicTrue
Just queryStr -> parseQueryOrDie queryStr
printSummary $ "Query: " ++ show query
entries <- queryEntries query
forM_ entries $ \entry -> do
hardLinks <- entryHardLinks entry
links <- if not $ null hardLinks
then return hardLinks
else entrySoftLinks entry
path <- case links of
[] -> projectDie $ concat
["list: Internal error, should have links for ", show entry, " but don't."]
link:_ -> return link
liftIO . putStrLn =<< pathRealize path
let entryCount = length entries
printSummary $ concat
["Found ", show entryCount, if entryCount == 1 then " entry." else " entries."]
Args.TagList {Args.tagListSpec = entrySpecStrMaybe} -> do
tags <- case entrySpecStrMaybe of
Nothing -> Set.toList <$> tagList
Just entrySpecStr -> tagLookup =<< parseEntrySpecOrDie entrySpecStr
forM_ tags $ liftIO . putStrLn . tagToRelativePath
Args.TagCreate {Args.tags = tagStrs} ->
forM_ tagStrs $ tagCreate <=< parseEntrySpecOrDie
Args.TagAdd { Args.files = files
, Args.tags = tagStrs
} -> do
projectPaths <- parsePathsOrDie files
entries <- findEntriesOrDie projectPaths
tags <- findTagsOrDie tagStrs
tagAdd entries tags
Args.TagRemove { Args.files = files
, Args.tags = tagStrs
} -> do
projectPaths <- parsePathsOrDie files
entries <- findEntriesOrDie projectPaths
tags <- findTagsOrDie tagStrs
tagRemove entries tags
Args.Realize { Args.tag = tagStr
, Args.query = queryStr
, Args.tagsInName = tagsInName
} -> do
-- Parse inputs.
entrySpec <- parseEntrySpecOrDie tagStr
query <- parseQueryOrDie queryStr
-- Look up (or create) the tag, and remove the tag's existing
-- association with all entries. If you're realizing a query for
-- entries with a tag, you don't want the target tag contributing to
-- that!
(tag, tagIsNew) <- tagCreate entrySpec
unless tagIsNew $ do
entriesOld <- queryEntries $ LogicQuery $ QueryTag $ Some $ LogicQuery $ TreeAt tag
tagRemove entriesOld [tag]
entriesNew <- queryEntries query
forM_ entriesNew $ \entry -> do
etags <- entryTags entry
sourcePath <- maybe (projectDie $ concat
["realize: ", show entry, " should have a source path."])
return =<<
entrySourcePath entry
-- If requested, then we add tags into link file names.
let linkFileName = if tagsInName
then Just $ replaceBaseName targetFileName newBaseName
else Nothing
-- The following are only used when tagsInName is true.
renderedTags =
map (map (\c -> if c == pathSeparator then '-' else c) .
tagToRelativePath) etags
targetFileName = takeFileName $ projectPathToRelativePath sourcePath
newBaseName = intercalate " " $ takeBaseName targetFileName : renderedTags
tagAdd1 entry tag linkFileName
let entryCount = length entriesNew
printSummary $ concat
["Found ", show entryCount, if entryCount == 1 then " entry." else " entries."]
_ -> projectDie "khph: Unimplemented command."
findProjectFile :: Bool -> FilePath -> IO (Maybe FilePath)
findProjectFile recur startingDirectory = do
contents <- getDirectoryContents startingDirectory
let projectFiles = filter (".khph" `isSuffixOf`) contents
case projectFiles of
projectFile:_ -> return $ Just $ startingDirectory </> projectFile
[] -> if recur
then let parent = takeDirectory startingDirectory
in if parent == startingDirectory
then return Nothing
else findProjectFile recur parent
else return Nothing
parsePathsOrDie :: MonadProject m => [FilePath] -> m [ProjectPath]
parsePathsOrDie pathStrs = do
(errors, projectPaths) <- partitionEithers <$> mapM parseRealPath pathStrs
if null errors
then return projectPaths
else projectDie $ concat $
"parsePathsOrDie: Couldn't parse some paths: " : map ("\n- " ++) errors
findEntriesOrDie :: MonadProject m => [ProjectPath] -> m [Entry m]
findEntriesOrDie projectPaths = do
entriesResult <- mapM (\p -> (,) p <$> entryAtPath p) projectPaths
case filter (isNothing . snd) entriesResult of
[] -> return $ catMaybes $ map snd entriesResult
xs -> projectDie $ concat $
"findEntriesOrDie: Couldn't find some entries: " :
map (("\n- " ++) . projectPathToRelativePath . fst) xs
findTagsOrDie :: MonadProject m => [String] -> m [Tag]
findTagsOrDie = mapM $ tagLookup1 "main" <=< parseEntrySpecOrDie
parseEntrySpecOrDie :: MonadProject m => String -> m EntrySpec
parseEntrySpecOrDie specStr = case toEntrySpec specStr of
Left err ->
projectDie $ concat
["parseEntrySpecOrDie: Couldn't parse EntrySpec from ", show specStr, ": ", err]
Right entrySpec -> return entrySpec
parseQueryOrDie :: MonadProject m => String -> m Query
parseQueryOrDie queryStr = do
queryResult <- parseQuery queryStr
case queryResult of
Left err ->
projectDie $ concat
["parseQueryOrDie: Error parsing query from ", show queryStr, ": ", err]
Right query -> return query