tintin-1.10.1: src/Tintin/ConfigurationLoading.hs

module Tintin.ConfigurationLoading
  ( ConfigurationLoading
  , loadInfo
  )
where

require Tintin.Errors
require Tintin.Capabilities.Logging
require Tintin.Capabilities.Filesystem
require Tintin.Domain.HtmlFile
require Tintin.Domain.Project

require Data.Text

import Tintin.Core
import qualified Universum.Unsafe as Unsafe
import Text.Read (read)
import qualified Text.Inflections as Inflections

data ConfigurationLoading

data ProjectContext = ProjectContext
  { name            :: Maybe Text
  , synopsis        :: Maybe Text
  , github          :: Maybe Text
  , location        :: Maybe Text
  , author          :: Maybe Text
  , projectLocation :: Filesystem.Path
  }

getFieldValue :: Text -> Text -> Maybe Text
getFieldValue field txt = txt
                        & lines
                        & filter (\t -> field `Text.isPrefixOf` Text.strip t)
                        & safeHead
                        & fmap Text.strip
                        & flatMap (Text.stripPrefix $ field <> ":")
                        & fmap Text.strip

loadProjectConfig :: ( Has Logging.Capability eff
                     , Has Filesystem.Capability eff
                     )
                   => Filesystem.Path -> Effectful eff ProjectContext
loadProjectConfig currentPath = do
  files <- Filesystem.list currentPath
  let packageYamlFile = find isPackageYaml files
  let cabalFile       = find isCabalFile files
  case packageYamlFile <|> cabalFile of
    Just file -> do
      Logging.debug "Reading project info"
      projectConfigFile <- Filesystem.readFile file
      return ProjectContext
        { name            = projectConfigFile & getFieldValue "name"
        , synopsis        = projectConfigFile & getFieldValue "synopsis"
        , github          = projectConfigFile & getFieldValue "github"
        , location        = projectConfigFile & getFieldValue "location"
        , author          = projectConfigFile & getFieldValue "author"
        , projectLocation = currentPath
        }
    Nothing -> return ProjectContext
      { name            = Nothing
      , synopsis        = Nothing
      , github          = Nothing
      , location        = Nothing
      , author          = Nothing
      , projectLocation = currentPath
      }
 where
  isPackageYaml (Filesystem.Path p) = p == "package.yaml"
  isCabalFile   (Filesystem.Path p) = ".cabal" `Text.isInfixOf` p

loadTintinConfig :: ( Has Logging.Capability eff
                    , Has Filesystem.Capability eff
                    )
                 => [Project.Page]
                 -> ProjectContext
                 -> Effectful eff Project.Info
loadTintinConfig pages ProjectContext {..} = do
  let Filesystem.Path currentPath = projectLocation
      tintinPath = Filesystem.Path $ currentPath <> "/.tintin.yml"
  tintinExists <- Filesystem.doesExist tintinPath
  unless tintinExists $ Filesystem.writeFile tintinPath "color: blue\n"
  tintinConfig <- Filesystem.readFile tintinPath
  let
    projectName           = (tintinConfig & getFieldValue "name") <|> name
    projectSynopsis       = (tintinConfig & getFieldValue "synopsis") <|> synopsis
    projectGithub         = (tintinConfig & getFieldValue "github") <|> github <|> location
    projectAuthor         = (tintinConfig & getFieldValue "author") <|> author
    authorWebsite         = (tintinConfig & getFieldValue "authorWebsite")
    tintinColor           = tintinConfig & getFieldValue "color"
    tintinLogo            = tintinConfig & getFieldValue "logo"
    tintinTitleFont       = (tintinConfig & getFieldValue "titleFont") <|> (Just $ fromString "Montserrat")
    tintinTitleFontWeight = (tintinConfig & getFieldValue "titleFontWeight") <|> (Just "500")
    tintinBodyFont        = (tintinConfig & getFieldValue "bodyFont") <|> (Just $ fromString "IBM+Plex+Sans")
  when (isNothing projectName) (Errors.showAndDie ["Project must have a name. Please set it in package.yaml or *.cabal."])
  when (isNothing projectSynopsis) (Errors.showAndDie ["Project must have a synopsis. Please set it in package.yaml or *.cabal."])
  when (isNothing tintinColor) (Errors.showAndDie [errorMessages])
  return Project.Info
    { name = Unsafe.fromJust projectName
    , synopsis        = Unsafe.fromJust projectSynopsis
    , githubLink      = parseGithubUrl <$> projectGithub
    , author          = projectAuthor
    , authorWebsite   = authorWebsite
    , color           = makeColor $ Unsafe.fromJust tintinColor
    , logoUrl         = tintinLogo
    , titleFont       = Unsafe.fromJust tintinTitleFont
    , titleFontWeight = read $ toString $ Unsafe.fromJust tintinTitleFontWeight
    , bodyFont        = Unsafe.fromJust tintinBodyFont
    , pages           = pages
    }
 where
  parseGithubUrl txt =
    let unquoted = stripGit $ stripQuotes txt
    in unquoted
       & Text.stripPrefix "github.com/"
       & fromMaybe unquoted
  stripGit txt =
    txt
      & Text.stripPrefix "git://"
      & flatMap (Text.stripSuffix ".git")
      & fromMaybe txt
  stripQuotes txt =
    txt
    & Text.stripPrefix "\""
    & flatMap (Text.stripSuffix "\"")
    & fromMaybe txt
  errorMessages = unlines
    ["Tintin usually generates a .tintin.yml file with a color configuration. Maybe you don't have enough permissions?"
    , ""
    , ""
    , "Try creating .tintin.yml and adding color:blue to it."
    ]

makeColor :: Text -> Project.Color
makeColor txt =
  case Text.stripPrefix "#" txt of
    Just _ -> Project.HexColor txt
    Nothing -> Inflections.SomeWord <$> Inflections.mkWord txt
      & Inflections.titleize
      & toString
      & read

loadInfo :: ( Has Logging.Capability eff
            , Has Filesystem.Capability eff
            )
         => [HtmlFile]
         -> Effectful eff Project.Info
loadInfo htmlFiles =
  Filesystem.currentDirectory
    >>= loadProjectConfig
    >>= loadTintinConfig pages
 where
  pages = htmlFiles & map (\HtmlFile.HtmlFile {..} -> Project.Page title content filename)