Kit.hs

{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Rank2Types             #-}
{-# LANGUAGE TemplateHaskell        #-}

{- |
Copyright: (c) 2018-2019 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

This module contains data types to work with application form. 'SummonKit' is
the data type containing the values manipulated by the fields in the form.
-}

module Summoner.Tui.Kit
       ( -- * Data types
         SummonKit (..)
       , User (..)
       , Project (..)
       , ProjectMeta (..)
       , GitHub (..)
       , renderWidgetTree
       , configToSummonKit
       , finalSettings

         -- * Lenses
         -- ** SummonKit
       , user
       , project
       , cabal
       , stack
       , projectMeta
       , gitHub
       , extensions
       , ghcOptions
       , connectMode
       , shouldSummon
       , configFile

         -- ** User
       , owner
       , fullName
       , email

         -- ** Project
       , repo
       , desc
       , category
       , license
       , maybeLicense

         -- ** ProjectMeta
       , lib
       , exe
       , test
       , bench
       , ghcs
       , preludeName
       , preludeModule

         -- ** GitHub
       , enabled
       , noUpload
       , private
       , actions
       , travis
       , appVeyor
       ) where

import Lens.Micro (Lens', lens, (.~), (^.))
import Lens.Micro.TH (makeFields)

import Summoner.Config (Config, ConfigP (..))
import Summoner.CustomPrelude (CustomPrelude (..))
import Summoner.Decision (Decision (..), decisionToBool, decisionsToBools)
import Summoner.Default (currentYear, defaultDescription, defaultGHC)
import Summoner.GhcVer (GhcVer)
import Summoner.License (LicenseName (..), fetchLicenseCustom)
import Summoner.Mode (ConnectMode (..), isOffline)
import Summoner.Settings (Settings (..))
import Summoner.Template (createProjectTemplate)
import Summoner.Tree (TreeFs, showTree)

import qualified Data.List as List (delete)
import qualified Data.Text as T


-- | Global TUI state.
data SummonKit = SummonKit
    { summonKitUser         :: !User
    , summonKitProject      :: !Project
    , summonKitCabal        :: !Bool
    , summonKitStack        :: !Bool
    , summonKitProjectMeta  :: !ProjectMeta
    , summonKitGitHub       :: !GitHub
    , summonKitExtensions   :: ![Text]  -- ^ Can be recieved from the config file.
    , summonKitGhcOptions   :: ![Text]  -- ^ Can be recieved from the config file.
    , summonKitGitignore    :: ![Text]  -- ^ Received from the config file.
    , summonKitConnectMode  :: !ConnectMode
    , summonKitShouldSummon :: !Decision  -- ^ Check if project needs to be created.
    , summonKitConfigFile   :: !(Maybe FilePath)  -- ^ Just if configuration file was used.
    , summonKitExtraFiles   :: ![TreeFs]  -- ^ Extra files
    } deriving stock (Show)

-- | User information.
data User = User
    { userOwner    :: !Text  -- ^ GitHub user or organization name.
    , userFullName :: !Text
    , userEmail    :: !Text
    } deriving stock (Show)

-- | Project related information
data Project = Project
    { projectRepo     :: !Text  -- ^ Project name.
    , projectDesc     :: !Text  -- ^ Short project description.
    , projectCategory :: !Text  -- ^ Comma-separated. See @Hackage@ for existing category list.
    , projectLicense  :: !LicenseName
    } deriving stock (Show)

-- | Project meta information.
data ProjectMeta = ProjectMeta
    { projectMetaLib           :: !Bool
    , projectMetaExe           :: !Bool
    , projectMetaTest          :: !Bool
    , projectMetaBench         :: !Bool
    , projectMetaGhcs          :: ![GhcVer]  -- ^ Default GHC version is always added.
    , projectMetaPreludeName   :: !Text
    , projectMetaPreludeModule :: !Text
    } deriving stock (Show)

-- | Github specific information.
data GitHub = GitHub
    { gitHubEnabled  :: !Bool
    , gitHubNoUpload :: !Bool  -- ^ Do not upload to GitHub, only local initialization.
    , gitHubPrivate  :: !Bool
    , gitHubActions  :: !Bool
    , gitHubTravis   :: !Bool
    , gitHubAppVeyor :: !Bool
    } deriving stock (Show)

makeFields ''SummonKit
makeFields ''User
makeFields ''Project
makeFields ''ProjectMeta
makeFields ''GitHub

-- | Lens for 'Maybe' 'LicenseName' in 'SummonKit'.
maybeLicense :: Lens' SummonKit (Maybe LicenseName)
maybeLicense = lens getL setL
  where
    getL :: SummonKit -> Maybe LicenseName
    getL = Just . projectLicense . summonKitProject

    setL :: SummonKit -> Maybe LicenseName -> SummonKit
    setL sk mbL = case mbL of
        Just l  -> sk & project . license .~ l
        Nothing -> sk

-- | Converts 'SummonKit' to main 'Settings' data type.
summonKitToSettings :: SummonKit -> Settings
summonKitToSettings sk = Settings
    { settingsRepo           = T.strip $ sk ^. project . repo
    , settingsOwner          = T.strip $ sk ^. user . owner
    , settingsDescription    = T.strip . unwords . lines $ sk ^. project . desc
    , settingsFullName       = T.strip $ sk ^. user . fullName
    , settingsEmail          = T.strip $ sk ^. user . email
    , settingsYear           = "20!8"
    , settingsCategories     = T.strip $ sk ^. project . category
    , settingsLicenseName    = sk ^. project . license
    , settingsLicenseText    = ""
    , settingsGitHub         = isGitHub
    , settingsGhActions      = isGitHub && sk ^. gitHub . actions && sk ^. cabal
    , settingsPrivate        = isGitHub && sk ^. gitHub . private
    , settingsTravis         = isGitHub && sk ^. gitHub . travis
    , settingsAppVeyor       = isGitHub && sk ^. gitHub . appVeyor
    , settingsIsLib          = sk ^. projectMeta . lib
    , settingsIsExe          = sk ^. projectMeta . exe
    , settingsTest           = sk ^. projectMeta . test
    , settingsBench          = sk ^. projectMeta . bench
    , settingsTestedVersions = sortNub $ defaultGHC : (sk ^. projectMeta . ghcs)
    , settingsPrelude        = cP
    , settingsExtensions     = sk ^. extensions
    , settingsGhcOptions     = sk ^. ghcOptions
    , settingsGitignore      = sk ^. gitignore
    , settingsCabal          = sk ^. cabal
    , settingsStack          = sk ^. stack
    , settingsNoUpload       = sk ^. gitHub . noUpload
    , settingsFiles          = sk ^. extraFiles
    }
  where
    isGitHub :: Bool
    isGitHub = sk ^. gitHub . enabled

    cP ::  Maybe CustomPrelude
    cP =
        let cpPackage = T.strip $ sk ^. projectMeta . preludeName
            cpModule  = T.strip $ sk ^. projectMeta . preludeModule
        in if ("" /= cpPackage) && ("" /= cpModule)
           then Just CustomPrelude{..}
           else Nothing

-- | Gets 'Settings' on successful application complition.
finalSettings :: SummonKit -> IO Settings
finalSettings sk = do
    year <- currentYear
    let licenseName = sk ^. project . license
    licenseText <- fetchLicenseCustom
        licenseName
        (sk ^. user . fullName)
        year

    pure (summonKitToSettings sk)
        { settingsYear = year
        , settingsLicenseText = licenseText
        }

-- | Gets the initial 'SummonKit' from the given 'Config'.
configToSummonKit
    :: Text  -- ^ Given project name
    -> ConnectMode  -- ^  @offline@ mode option
    -> Maybe FilePath  -- ^ Configuration file used
    -> [TreeFs]  -- ^ Extra files
    -> Config  -- ^ Given configurations.
    -> SummonKit
configToSummonKit cRepo cConnectMode cConfigFile files ConfigP{..} = SummonKit
    { summonKitUser  = User
        { userOwner    = cOwner
        , userFullName = cFullName
        , userEmail    = cEmail
        }
    , summonKitProject = Project
        { projectRepo     = cRepo
        , projectDesc     = defaultDescription
        , projectCategory = ""
        , projectLicense  = if isOffline cConnectMode then NONE else cLicense
        }
    , summonKitProjectMeta = ProjectMeta
        { projectMetaLib = kitLib
        , projectMetaExe = kitExe
        , projectMetaTest  = decisionToBool cTest
        , projectMetaBench = decisionToBool cBench
        , projectMetaGhcs = List.delete defaultGHC cGhcVer
        , projectMetaPreludeName = kitPreludeName
        , projectMetaPreludeModule = kitPreludeModule
        }
    , summonKitCabal = kitCabal
    , summonKitStack = kitStack
    , summonKitGitHub = GitHub
        { gitHubEnabled  = cGitHub /= Nop
        , gitHubNoUpload = getAny cNoUpload || isOffline cConnectMode
        , gitHubPrivate  = decisionToBool cPrivate
        , gitHubActions  = (cGitHub /= Nop) && (cGhActions /= Nop) && kitCabal
        , gitHubTravis   = (cGitHub /= Nop) && (cTravis /= Nop)
        , gitHubAppVeyor = decisionToBool cAppVey
        }
    , summonKitExtensions   = cExtensions
    , summonKitGhcOptions   = cGhcOptions
    , summonKitGitignore    = cGitignore
    , summonKitConnectMode  = cConnectMode
    , summonKitShouldSummon = Nop
    , summonKitConfigFile   = cConfigFile
    , summonKitExtraFiles   = files
    }
  where
    kitCabal, kitStack, kitLib, kitExe :: Bool
    (kitCabal, kitStack) = decisionsToBools (cCabal, cStack)
    (kitLib, kitExe) = decisionsToBools (cLib, cExe)

    kitPreludeName, kitPreludeModule :: Text
    (kitPreludeName, kitPreludeModule) = case getLast cPrelude of
        Nothing                -> ("", "")
        Just CustomPrelude{..} -> (cpPackage, cpModule)

-- | Shows the Widget with the generated project structure tree.
renderWidgetTree :: SummonKit -> Text
renderWidgetTree = showTree False . createProjectTemplate . summonKitToSettings