{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TemplateHaskell #-}
module Summoner.Tui.Kit
(
SummonKit (..)
, User (..)
, Project (..)
, ProjectMeta (..)
, GitHub (..)
, renderWidgetTree
, configToSummonKit
, finalSettings
, user
, project
, cabal
, stack
, projectMeta
, gitHub
, extensions
, ghcOptions
, stylish
, contributing
, offline
, shouldSummon
, configFile
, owner
, fullName
, email
, repo
, desc
, category
, license
, maybeLicense
, lib
, exe
, test
, bench
, ghcs
, preludeName
, preludeModule
, enabled
, noUpload
, private
, travis
, appVeyor
) where
import Lens.Micro (Lens', lens, (.~), (^.))
import Lens.Micro.TH (makeFields)
import Summoner.Config (Config, ConfigP (..))
import Summoner.Decision (Decision (..))
import Summoner.Default (currentYear, defaultDescription, defaultGHC)
import Summoner.GhcVer (GhcVer)
import Summoner.License (LicenseName (..), customizeLicense, fetchLicense)
import Summoner.Settings (CustomPrelude (..), Settings (..))
import Summoner.Source (Source, fetchSource)
import Summoner.Template (createProjectTemplate)
import Summoner.Tree (showTree)
import qualified Data.List as List (delete)
import qualified Data.Text as T
data SummonKit = SummonKit
{ summonKitUser :: !User
, summonKitProject :: !Project
, summonKitCabal :: !Bool
, summonKitStack :: !Bool
, summonKitProjectMeta :: !ProjectMeta
, summonKitGitHub :: !GitHub
, summonKitExtensions :: ![Text]
, summonKitGhcOptions :: ![Text]
, summonKitGitignore :: ![Text]
, summonKitStylish :: !(Maybe Source)
, summonKitContributing :: !(Maybe Source)
, summonKitOffline :: !Bool
, summonKitShouldSummon :: !Decision
, summonKitConfigFile :: !(Maybe FilePath)
} deriving (Show)
data User = User
{ userOwner :: !Text
, userFullName :: !Text
, userEmail :: !Text
} deriving (Show)
data Project = Project
{ projectRepo :: !Text
, projectDesc :: !Text
, projectCategory :: !Text
, projectLicense :: !LicenseName
} deriving (Show)
data ProjectMeta = ProjectMeta
{ projectMetaLib :: !Bool
, projectMetaExe :: !Bool
, projectMetaTest :: !Bool
, projectMetaBench :: !Bool
, projectMetaGhcs :: ![GhcVer]
, projectMetaPreludeName :: !Text
, projectMetaPreludeModule :: !Text
} deriving (Show)
data GitHub = GitHub
{ gitHubEnabled :: !Bool
, gitHubNoUpload :: !Bool
, gitHubPrivate :: !Bool
, gitHubTravis :: !Bool
, gitHubAppVeyor :: !Bool
} deriving (Show)
makeFields ''SummonKit
makeFields ''User
makeFields ''Project
makeFields ''ProjectMeta
makeFields ''GitHub
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
summonKitToSettings :: SummonKit -> Settings
summonKitToSettings sk = Settings
{ settingsRepo = T.strip $ sk ^. project . repo
, settingsOwner = T.strip $ sk ^. user . owner
, settingsDescription = T.strip $ 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
, settingsPrivate = isGitHub && sk ^. gitHub . private
, settingsTravis = isGitHub && sk ^. gitHub . travis
, settingsAppVeyor = isGitHub && sk ^. gitHub . appVeyor && sk ^. stack
, settingsIsLib = sk ^. projectMeta . lib
, settingsIsExe = sk ^. projectMeta . exe
, settingsTest = sk ^. projectMeta . test
, settingsBench = sk ^. projectMeta . bench
, settingsTestedVersions = sortNub $ defaultGHC : (sk ^. projectMeta . ghcs)
, settingsBaseType = baseT
, settingsPrelude = cP
, settingsExtensions = sk ^. extensions
, settingsGhcOptions = sk ^. ghcOptions
, settingsGitignore = sk ^. gitignore
, settingsCabal = sk ^. cabal
, settingsStack = sk ^. stack
, settingsStylish = "" <$ sk ^. stylish
, settingsContributing = "" <$ sk ^. contributing
, settingsNoUpload = sk ^. gitHub . noUpload
}
where
isGitHub :: Bool
isGitHub = sk ^. gitHub . enabled
baseT :: Text
cP :: Maybe CustomPrelude
(baseT, cP) =
let cpPackage = T.strip $ sk ^. projectMeta . preludeName
cpModule = T.strip $ sk ^. projectMeta . preludeModule
in if ("" /= cpPackage) && ("" /= cpModule)
then ("base-noprelude", Just CustomPrelude{..})
else ("base", Nothing)
finalSettings :: SummonKit -> IO Settings
finalSettings sk = do
year <- currentYear
let licenseName = sk ^. project . license
fetchedLicense <- fetchLicense licenseName
let licenseText = customizeLicense
licenseName
fetchedLicense
(sk ^. user . fullName)
year
let fetch = maybe (pure Nothing) (fetchSource (sk ^. offline))
sStylish <- fetch $ sk ^. stylish
sContributing <- fetch $ sk ^. contributing
pure (summonKitToSettings sk)
{ settingsYear = year
, settingsLicenseText = licenseText
, settingsStylish = sStylish
, settingsContributing = sContributing
}
configToSummonKit
:: Text
-> Bool
-> Maybe FilePath
-> Config
-> SummonKit
configToSummonKit cRepo cOffline cConfigFile Config{..} = SummonKit
{ summonKitUser = User
{ userOwner = cOwner
, userFullName = cFullName
, userEmail = cEmail
}
, summonKitProject = Project
{ projectRepo = cRepo
, projectDesc = defaultDescription
, projectCategory = ""
, projectLicense = if cOffline then None else cLicense
}
, summonKitProjectMeta = ProjectMeta
{ projectMetaLib = kitLib
, projectMetaExe = kitExe
, projectMetaTest = toBool cTest
, projectMetaBench = toBool cBench
, projectMetaGhcs = List.delete defaultGHC cGhcVer
, projectMetaPreludeName = kitPreludeName
, projectMetaPreludeModule = kitPreludeModule
}
, summonKitCabal = kitCabal
, summonKitStack = kitStack
, summonKitGitHub = GitHub
{ gitHubEnabled = cGitHub /= Nop
, gitHubNoUpload = getAny cNoUpload || cOffline
, gitHubPrivate = toBool cPrivate
, gitHubTravis = (cGitHub /= Nop) && (cTravis /= Nop)
, gitHubAppVeyor = toBool cAppVey && kitStack
}
, summonKitExtensions = cExtensions
, summonKitGhcOptions = cWarnings ++ cGhcOptions
, summonKitGitignore = cGitignore
, summonKitStylish = getLast cStylish
, summonKitContributing = getLast cContributing
, summonKitOffline = cOffline
, summonKitShouldSummon = Nop
, summonKitConfigFile = cConfigFile
}
where
kitCabal, kitStack, kitLib, kitExe :: Bool
(kitCabal, kitStack) = decToBools (cCabal, cStack)
(kitLib, kitExe) = decToBools (cLib, cExe)
decToBools :: (Decision, Decision) -> (Bool, Bool)
decToBools = \case
(Idk, Idk) -> (True, True)
(Yes, Idk) -> (True, False)
(Idk, Yes) -> (False, True)
(Nop, Idk) -> (False, True)
(Idk, Nop) -> (True, False)
(x, y) -> (toBool x, toBool y)
toBool :: Decision -> Bool
toBool = \case
Yes -> True
Nop -> False
Idk -> False
kitPreludeName, kitPreludeModule :: Text
(kitPreludeName, kitPreludeModule) = case getLast cPrelude of
Nothing -> ("", "")
Just CustomPrelude{..} -> (cpPackage, cpModule)
renderWidgetTree :: SummonKit -> Text
renderWidgetTree = showTree False . createProjectTemplate . summonKitToSettings