Options.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeOperators         #-}


module Parochial.Options (
    Config(..)
  , getAndMkTargetPath
  , getState
  , parseCmdOptions
  ) where

import           Protolude hiding (state)

import qualified Data.Text as T

import           Distribution.Simple.Flag
import           Distribution.Simple.Utils hiding (findFile)
import           Distribution.Simple.Configure

import           System.Directory
import           System.FilePath

import           System.FilePattern.Directory

import           Options.Generic

import           Parochial.Types


data Config w
     = Haddock
       { target    :: w ::: Maybe FilePath  <?> "Target directory"
       , project   :: w ::: Maybe Text      <?> "The name of the project. Default to project name derived from $CWD"
       , state     :: w ::: Maybe FilePath  <?> "The state file"
       }
     | Hoogle
       { target    :: w ::: Maybe FilePath  <?> "Target directory"
       , project   :: w ::: Maybe Text      <?> "The name of the project. Default to project name derived from $CWD"
       , state     :: w ::: Maybe FilePath  <?> "The state file"
       }
     deriving (Generic)


instance ParseRecord (Config Wrapped)
deriving instance Show (Config Unwrapped)


setupConfigFile :: FilePath
setupConfigFile = "setup-config"


defaultDistDir :: FilePath
defaultDistDir = "dist-newstyle"


getCurrentProject :: Maybe Text -> IO Text
getCurrentProject = maybe (unhide . toS . takeFileName <$> getCurrentDirectory) pure


unhide :: Text -> Text
unhide = T.dropWhile ('.' ==)


targetBaseName :: FilePath
targetBaseName = "parochial"


defaultPath :: Target
defaultPath = "/srv" </> targetBaseName


-- | What the target directory should be. This checks the --target option and if set uses
--   is otherwise it uses @bestTarget@ to work out what to do.
defaultTarget :: Maybe FilePath -> IO Target
defaultTarget = maybe bestTarget pure


getAndMkTargetPath :: Maybe Text -> Maybe FilePath -> IO Target
getAndMkTargetPath p t = getTarget >>= mkTargetPath
  where
    getTarget = (</>) <$> defaultTarget t <*> (toS <$> getCurrentProject p)
    mkTargetPath p' = createDirectoryIfMissing True p' >> pure p'


-- | Take the value from either the --state option or find the setup-config itself.
getState :: Maybe FilePath -> IO FilePath
getState = maybe findSetupConfig pure


-- | Try and find the setup-config file. This is *very* primative at the moment and
--   will simply search for the first path returned by **/x/**/setup-config
findSetupConfig :: IO FilePath
findSetupConfig = do
  d <- dist
  findS d >>= maybe (dieNoVerbosity ("Can't find: " <> setupConfigFile)) (pure . (d </>))

  where
    dist :: IO FilePath
    dist = findDistPref "." (Flag defaultDistDir)

    findS :: FilePath -> IO (Maybe FilePath)
    findS d = head <$> getDirectoryFiles d ["**/x/**" </> setupConfigFile]


parseCmdOptions :: MonadIO m => m (Config Unwrapped)
parseCmdOptions = unwrapRecord "Generate project specific haddocks"


-- | Check if defaultTarget exists and if not check that the parent directory is writable.
--   If the parent directory is writable then create it otherwise use $HOME/.parochial.
--   I'm not sure if this is the best place but I'm not sure where to put it! $HOME/.local/srv
--   would be best but this isn't covered by any standard I know off and therefore really
--   confusing to everyone else. <general heavy sigh>
bestTarget :: IO Target
bestTarget = doesDefaultTargetExist >>= boolWithDef (isParentWritable >>=  boolWithDef homeTarget)
  where
    doesDefaultTargetExist = doesDirectoryExist defaultPath
    isParentWritable = writable <$> getPermissions (takeDirectory defaultPath)


-- | If the second argument is True then return the @defaultPath@ otherwise evaluate the
--   second argument.
boolWithDef :: Applicative f => f Target -> Bool -> f Target
boolWithDef = flip bool (pure defaultPath)


homeTarget :: IO Target
homeTarget = getXdgDirectory XdgData targetBaseName