Monad.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 #-}

-- | A monad for performing operations on a project.
module Khph.Project.Monad (
  MonadProject (..),
  dumpProjectContents,
  ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative)
#endif
import Control.Monad (forM_)
import Control.Monad.Trans (lift)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Set (Set)
import Khph.Config (Config)
import Khph.Project.Base
import Khph.Query.Base
import Text.Parsec (ParsecT)

-- | A monad for performing operations on a project.
class (Functor m, Applicative m, Monad m) => MonadProject m where
  -- | A data type representing an entry in the project.
  type Entry m

  -- | Prints out a warning message.
  projectWarn :: String -> m ()

  -- | Prints out an error message, then aborts execution.
  projectDie :: String -> m a

  -- | Prints out a summary message.
  printSummary :: String -> m ()

  -- | Prints out notification of a file action.
  printFileAction :: String -> m ()

  -- | Returns the project's configuration.
  getConfig :: m Config

  -- | If the program's current path is within the project, then this returns
  -- the corresponding 'ProjectPath', calling 'projectDie' otherwise.  The
  -- argument is a sentence fragment explaing the cause, starting with "because
  -- ...", "for ...", etc. and not ending in punctuation.
  getCurrentPathOrDie :: String -> m ProjectPath

  -- | Takes a file path and canonicalizes it.  If this path is below the
  -- project root then a 'ProjectPath' is returned, otherwise an error message
  -- is returned.
  parseRealPath :: FilePath -> m (Either String ProjectPath)

  -- | Converts a 'ProjectPath' to an absolute 'FilePath'.
  pathRealize :: ProjectPath -> m FilePath

  -- | Converts an 'EntrySpec' into 'ProjectPaths' as follows.  Absolute and
  -- relative 'EntrySpec's get converted to the single path that they point to,
  -- __whether or not it exists__.  By-name 'EntrySpec's get converted to the
  -- list of paths that __actually exist__.
  entrySpecLookup :: EntrySpec -> m [ProjectPath]

  -- | Checks whether there is an entry at a specific path, and returns it, if
  -- found.
  entryAtPath :: ProjectPath -> m (Maybe (Entry m))

  -- | Runs a query over entries in the project.
  queryEntries :: Query -> m [Entry m]

  -- | Returns all of an entry's hard links.
  entryHardLinks :: Entry m -> m [ProjectPath]

  -- | Returns all of an entry's soft links.
  entrySoftLinks :: Entry m -> m [ProjectPath]

  -- | Returns an arbitrary source path for an entry, if it has one.
  entrySourcePath :: Entry m -> m (Maybe ProjectPath)

  -- | Returns all of the tags associated with an entry.
  entryTags :: Entry m -> m [Tag]

  -- | Returns all tags.
  tagList :: m (Set Tag)

  -- | Returns all tags that match a specification.
  tagLookup :: EntrySpec -> m [Tag]

  -- | @'tagLookup1' caller spec@ calls @'tagLookup' spec@.  If 'tagLookup'
  -- returns a single tag, then so does 'tagLookup1'.  If 'tagLookup' returns
  -- zero or multiple entries, then 'tagLookup1' calls 'projectDie' with an
  -- error message that includes @caller@.
  tagLookup1 :: String -> EntrySpec -> m Tag
  tagLookup1 caller spec = do
    tags <- tagLookup spec
    case tags of
      [tag] -> return tag
      _ -> do
        let count = length tags
        projectDie $ concat
          ["tagLookup1 via ", caller, ": ", show spec,
           " should match one tag but matched ",
           show count, ": ", show (take 10 tags),
           if count > 10 then ", ..." else ""]

  -- | Creates a tag, if it doesn't exist.  Returns the tag, and whether the tag
  -- was newly created.  By-name specifications are not allowed here.
  tagCreate :: EntrySpec -> m (Tag, Bool)

  -- | Associates each entry with each tag given.
  tagAdd :: [Entry m] -> [Tag] -> m ()

  -- | Associates an entry with a single tag.  If given a @Just String@, the string will be
  -- used for the file name of the soft link created (but if the entry already
  -- has this tag, then a link already exists and this link won't be created).
  tagAdd1 :: Entry m -> Tag -> Maybe String -> m ()

  -- | Disassociates each entry from each tag given.
  tagRemove :: [Entry m] -> [Tag] -> m ()

instance MonadProject m => MonadProject (ParsecT s u m) where
  type Entry (ParsecT s u m) = Entry m

  projectWarn = lift . projectWarn
  projectDie = lift . projectDie
  printSummary = lift . printSummary
  printFileAction = lift . printFileAction
  getConfig = lift getConfig
  getCurrentPathOrDie = lift . getCurrentPathOrDie
  parseRealPath = lift . parseRealPath
  pathRealize = lift . pathRealize
  entrySpecLookup = lift . entrySpecLookup
  entryAtPath = lift . entryAtPath
  queryEntries = lift . queryEntries
  entryHardLinks = lift . entryHardLinks
  entrySoftLinks = lift . entrySoftLinks
  entrySourcePath = lift . entrySourcePath
  entryTags = lift . entryTags
  tagList = lift tagList
  tagLookup = lift . tagLookup
  tagLookup1 = (lift .) . tagLookup1
  tagCreate = lift . tagCreate
  tagAdd = (lift .) . tagAdd
  tagAdd1 = ((lift .) .) . tagAdd1
  tagRemove = (lift .) . tagRemove

dumpProjectContents :: (MonadIO m, MonadProject m) => m ()
dumpProjectContents = do
  liftIO $ putStrLn "<<< Project contents dump"
  entries <- queryEntries LogicTrue
  forM_ entries $ \entry -> do
    liftIO $ putStrLn "- Entry"
    hardLinks <- entryHardLinks entry
    softLinks <- entrySoftLinks entry
    tags <- entryTags entry
    forM_ hardLinks $ showLink "Hard"
    forM_ softLinks $ showLink "Soft"
    forM_ tags $ \tag -> liftIO $ putStrLn $ concat ["  - Tag: ", tagToRelativePath tag]
  liftIO $ putStrLn ">>> Project contents dump"

  where showLink label projectPath = do
          let path = projectPathToRelativePath projectPath
          liftIO $ putStrLn $ concat ["  - ", label, " link: ", show path]