[#58] Make License type safer (#123)

* [#58] Make License type safer

* Rename license types

* Fix style

* Fix lastT and style

* Update choose

* Remove forall

* Refactor choose function

* Fix choose function

* Swap with whenNothing

* Fix style

* Fix 3 errors

* Refactor Read instance

* Fix style

* Implement without read

* Make choose more universal

CHANGELOG.md

@@ -17,6 +17,8 @@
   Add TOML test
 * [#120](https://github.com/kowainik/summoner/issues/120):
   Bump up dependencies
+* [#58](https://github.com/kowainik/summoner/issues/58):
+  Make `Licence` type safer
 
 1.0.6
 =====

src/Summoner/Config.hs

@@ -33,7 +33,7 @@ import Generics.Deriving.Monoid (GMonoid, gmemptydefault)
 import Generics.Deriving.Semigroup (GSemigroup, gsappenddefault)
 import Toml (AnyValue (..), BiToml, Key, Prism (..), dimap, (.=))
 
-import Summoner.License (License (..))
+import Summoner.License (LicenseName (..), parseLicenseName)
 import Summoner.ProjectData (CustomPrelude (..), Decision (..), GhcVer (..), parseGhcVer,
                              showGhcVer)
 import Summoner.Validation (Validation (..))
@@ -48,7 +48,7 @@ data ConfigP (p :: Phase) = Config
     { cOwner      :: p :- Text
     , cFullName   :: p :- Text
     , cEmail      :: p :- Text
-    , cLicense    :: p :- License
+    , cLicense    :: p :- LicenseName
     , cGhcVer     :: p :- [GhcVer]
     , cCabal      :: Decision
     , cStack      :: Decision
@@ -66,10 +66,26 @@ data ConfigP (p :: Phase) = Config
     , cWarnings   :: [Text]
     } deriving (Generic)
 
-deriving instance (GSemigroup (p :- Text), GSemigroup (p :- License), GSemigroup (p :- [GhcVer])) => GSemigroup (ConfigP p)
-deriving instance (GMonoid (p :- Text), GMonoid (p :- License), GMonoid (p :- [GhcVer])) => GMonoid (ConfigP p)
-deriving instance (Eq (p :- Text), Eq (p :- License), Eq (p :- [GhcVer]), Eq (Last CustomPrelude)) => Eq (ConfigP p)
-deriving instance (Show (p :- Text), Show (p :- License), Show (p :- [GhcVer])) => Show (ConfigP p)
+deriving instance
+    ( GSemigroup (p :- Text)
+    , GSemigroup (p :- LicenseName)
+    , GSemigroup (p :- [GhcVer])
+    ) => GSemigroup (ConfigP p)
+deriving instance
+    ( GMonoid (p :- Text)
+    , GMonoid (p :- LicenseName)
+    , GMonoid (p :- [GhcVer])
+    ) => GMonoid (ConfigP p)
+deriving instance
+    ( Eq (p :- Text)
+    , Eq (p :- LicenseName)
+    , Eq (p :- [GhcVer])
+    ) => Eq (ConfigP p)
+deriving instance
+    ( Show (p :- Text)
+    , Show (p :- LicenseName)
+    , Show (p :- [GhcVer])
+    ) => Show (ConfigP p)
 
 infixl 3 :-
 type family phase :- field where
@@ -95,7 +111,7 @@ defaultConfig = Config
     { cOwner    = Last (Just "kowainik")
     , cFullName = Last (Just "Kowainik")
     , cEmail    = Last (Just "xrom.xkov@gmail.com")
-    , cLicense  = Last (Just $ License "MIT")
+    , cLicense  = Last (Just MIT)
     , cGhcVer   = Last (Just [])
     , cCabal    = Idk
     , cStack    = Idk
@@ -137,7 +153,7 @@ configT = Config
     <*> textArr         "warnings"    .= cWarnings
   where
     lastT :: (Key -> BiToml a) -> Key -> BiToml (Last a)
-    lastT f = dimap getLast Last . Toml.maybeT f
+    lastT = Toml.wrapper . Toml.maybeT
 
     _GhcVer :: Prism AnyValue GhcVer
     _GhcVer = Prism
@@ -148,8 +164,8 @@ configT = Config
     ghcVerArr :: Key -> BiToml [GhcVer]
     ghcVerArr = Toml.arrayOf _GhcVer
 
-    license :: Key -> BiToml License
-    license =  dimap unLicense License . Toml.text
+    license :: Key -> BiToml LicenseName
+    license = Toml.mdimap show parseLicenseName . Toml.text
 
     textArr :: Key -> BiToml [Text]
     textArr = dimap Just maybeToMonoid . Toml.maybeT (Toml.arrayOf Toml._Text)

src/Summoner/License.hs

@@ -1,51 +1,78 @@
 module Summoner.License
-       ( License (..)
+       ( LicenseName(..)
+       , License(..)
        , customizeLicense
-       , licenseNames
        , githubLicenseQueryNames
+       , parseLicenseName
        ) where
 
 import Relude
+import Relude.Extra.Enum (inverseMap)
 
 import Data.Aeson (FromJSON (..), withObject, (.:))
 
 import qualified Data.Text as T
+import qualified Text.Show as TS
 
 ----------------------------------------------------------------------------
 -- License
 ----------------------------------------------------------------------------
 
-licenseNames :: [License]
-licenseNames = map fst githubLicenseQueryNames
-
-githubLicenseQueryNames :: [(License, Text)]
-githubLicenseQueryNames =
-    [ ("MIT",        "mit")
-    , ("BSD2",       "bsd-2-clause")
-    , ("BSD3",       "bsd-3-clause")
-    , ("GPL-2",      "gpl-2.0")
-    , ("GPL-3",      "gpl-3.0")
-    , ("LGPL-2.1",   "lgpl-2.1")
-    , ("LGPL-3",     "lgpl-3.0")
-    , ("AGPL-3",     "agpl-3.0")
-    , ("Apache-2.0", "apache-2.0")
-    , ("MPL-2.0",    "mpl-2.0")
-    ]
+data LicenseName
+    = MIT
+    | BSD2
+    | BSD3
+    | GPL2
+    | GPL3
+    | LGPL21
+    | LGPL3
+    | AGPL3
+    | Apache20
+    | MPL20
+    deriving (Eq, Ord, Enum, Bounded, Generic)
+
+instance Show LicenseName where
+    show MIT      = "MIT"
+    show BSD2     = "BSD2"
+    show BSD3     = "BSD3"
+    show GPL2     = "GPL-2"
+    show GPL3     = "GPL-3"
+    show LGPL21   = "LGPL-2.1"
+    show LGPL3    = "LGPL-3"
+    show AGPL3    = "AGPL-3"
+    show Apache20 = "Apache-2.0"
+    show MPL20    = "MPL-2.0"
 
 newtype License = License { unLicense :: Text }
-    deriving (IsString, Eq, Ord, Show)
+    deriving (IsString, Show, Generic)
 
 instance FromJSON License where
     parseJSON = withObject "License" $ \o -> License <$> o .: "body"
 
-customizeLicense :: Text -> Text -> Text -> Text -> Text
+githubLicenseQueryNames :: LicenseName -> Text
+githubLicenseQueryNames = \case
+    MIT      -> "mit"
+    BSD2     -> "bsd-2-clause"
+    BSD3     -> "bsd-3-clause"
+    GPL2     -> "gpl-2.0"
+    GPL3     -> "gpl-3.0"
+    LGPL21   -> "lgpl-2.1"
+    LGPL3    -> "lgpl-3.0"
+    AGPL3    -> "agpl-3.0"
+    Apache20 -> "apache-2.0"
+    MPL20    -> "mpl-2.0"
+
+parseLicenseName :: Text -> Maybe LicenseName
+parseLicenseName = inverseMap show
+
+customizeLicense :: LicenseName -> Text -> Text -> Text -> Text
 customizeLicense l t nm year
-    | l `elem` words "MIT BSD2 BSD3" = updateLicenseText
-    | otherwise = t
+    | l `elem` [MIT, BSD2, BSD3] = updateLicenseText
+    | otherwise                  = t
   where
     updateLicenseText =
         let (beforeY, withY) = T.span (/= '[') t
-            afterY = T.tail $ T.dropWhile (/= ']') withY
+            afterY           = T.tail $ T.dropWhile (/= ']') withY
             (beforeN, withN) = T.span (/= '[') afterY
-            afterN = T.tail $ T.dropWhile (/= ']') withN
-        in beforeY <> year <> beforeN <> nm <> afterN
+            afterN           = T.tail $ T.dropWhile (/= ']') withN
+        in  beforeY <> year <> beforeN <> nm <> afterN

src/Summoner/Project.hs

@@ -19,7 +19,7 @@ import System.Process (readProcess)
 import Summoner.Ansi (errorMessage, infoMessage, successMessage)
 import Summoner.Config (Config, ConfigP (..))
 import Summoner.Default (currentYear, defaultGHC)
-import Summoner.License (License (..), customizeLicense, githubLicenseQueryNames, licenseNames)
+import Summoner.License (License (..), customizeLicense, githubLicenseQueryNames, parseLicenseName)
 import Summoner.Process ()
 import Summoner.ProjectData (CustomPrelude (..), Decision (..), ProjectData (..), parseGhcVer,
                              showGhcVer)
@@ -30,8 +30,6 @@ import Summoner.Template (createStackTemplate)
 import Summoner.Text (intercalateMap, packageToModule)
 import Summoner.Tree (showTree, traverseTree)
 
-import qualified Relude.Unsafe as Unsafe
-
 decisionToBool :: Decision -> Text -> IO Bool
 decisionToBool decision target = case decision of
     Yes -> trueMessage  target
@@ -51,13 +49,10 @@ generateProject projectName Config{..} = do
     email       <- queryDef "Maintainer e-mail: " cEmail
     putText categoryText
     category <- query "Category: "
-    license  <- choose "License: " $ map unLicense $ ordNub (cLicense : licenseNames)
+    license  <- choose parseLicenseName "License: " $ ordNub (cLicense : universe)
 
     -- License creation
-    let licenseGithub = snd
-                      $ Unsafe.head
-                      $ dropWhile ((/= license) . unLicense . fst) githubLicenseQueryNames
-    let licenseLink = "https://api.github.com/licenses/" <> licenseGithub
+    let licenseLink = "https://api.github.com/licenses/" <> githubLicenseQueryNames license
     licenseJson <-
       readProcess "curl"
                   [ toString licenseLink

src/Summoner/ProjectData.hs

@@ -21,6 +21,8 @@ import Relude.Extra.Enum (inverseMap)
 import Generics.Deriving.Monoid (GMonoid (..))
 import Generics.Deriving.Semigroup (GSemigroup (..))
 
+import Summoner.License (LicenseName)
+
 import qualified Data.Text as T
 
 -- | Data needed for project creation.
@@ -32,7 +34,7 @@ data ProjectData = ProjectData
     , email          :: Text   -- ^ e-mail
     , year           :: Text   -- ^ year
     , category       :: Text   -- ^ project category
-    , license        :: Text   -- ^ type of license
+    , license        :: LicenseName   -- ^ type of license
     , licenseText    :: Text   -- ^ license text
     , github         :: Bool   -- ^ github repository
     , travis         :: Bool   -- ^ Travis CI integration

src/Summoner/Question.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE MultiWayIf          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
 
 -- | This module contains function to proper questioning in terminal.
 
@@ -45,15 +47,15 @@ printQuestion question (def:rest) = do
     putTextLn $ "/" <> restSlash
 printQuestion question [] = T.putStrLn question
 
-choose :: Text -> [Text] -> IO Text
-choose question choices = do
-    printQuestion question choices
+choose :: Show a => (Text -> Maybe a) -> Text -> [a] -> IO a
+choose parser question choices = do
+    let showChoices = map show choices
+    printQuestion question showChoices
     answer <- prompt
-    if | T.null answer -> pure (Unsafe.head choices)
-       | answer `elem` choices -> pure answer
-       | otherwise -> do
-           errorMessage "This wasn't a valid choice."
-           choose question choices
+    if T.null answer
+        then pure (Unsafe.head choices)
+        else whenNothing (parser answer)
+                (errorMessage "This wasn't a valid choice." >> choose parser question choices)
 
 chooseYesNo :: Text -- ^ target
             -> IO a -- ^ action for 'Y' answer

src/Summoner/Template.hs

@@ -57,6 +57,8 @@ createStackTemplate ProjectData{..} = Dir (toString repo) $
  ++ [File "b" scriptSh | script]
   where
     -- Creates module name from the name of the project
+    licenseName = show license
+
     libModuleName :: Text
     libModuleName = packageToModule repo
 
@@ -74,13 +76,14 @@ createStackTemplate ProjectData{..} = Dir (toString repo) $
     createCabalTop :: Text
     createCabalTop =
         [text|
+        cabal-version:       1.24
         name:                $repo
         version:             0.0.0
         description:         $description
         synopsis:            $description
         homepage:            https://github.com/${owner}/${repo}
         bug-reports:         https://github.com/${owner}/${repo}/issues
-        license:             $license
+        license:             $licenseName
         license-file:        LICENSE
         author:              $nm
         maintainer:          $email
@@ -89,7 +92,6 @@ createStackTemplate ProjectData{..} = Dir (toString repo) $
         build-type:          Simple
         extra-doc-files:     README.md
                            , CHANGELOG.md
-        cabal-version:       1.24
         tested-with:         $testedGhcs
         $endLine
         |]
@@ -301,7 +303,7 @@ createStackTemplate ProjectData{..} = Dir (toString repo) $
         # $repo
 
         [![Hackage]($hackageShield)]($hackageLink)
-        [![$license license](${licenseShield})](${licenseLink})
+        [![$licenseName license](${licenseShield})](${licenseLink})
         $stackBadges
         $travisBadge
         $appVeyorBadge
@@ -346,7 +348,7 @@ createStackTemplate ProjectData{..} = Dir (toString repo) $
             [text|[![Windows build status](${appVeyorShield})](${appVeyorLink})|]
 
         licenseShield :: Text =
-          "https://img.shields.io/badge/license-" <> T.replace "-" "--" license <> "-blue.svg"
+          "https://img.shields.io/badge/license-" <> T.replace "-" "--" licenseName <> "-blue.svg"
         licenseLink :: Text =
           "https://github.com/" <> owner <> "/" <> repo <> "/blob/master/LICENSE"
 

test/Test/TomlSpec.hs

@@ -3,14 +3,15 @@
 module Test.TomlSpec where
 
 import Relude
+import Relude.Extra.Enum (universe)
 
 import Hedgehog (MonadGen, forAll, property, tripping)
 import Test.Tasty (TestTree)
 import Test.Tasty.Hedgehog (testProperty)
 import Toml.Bi.Code (decode, encode)
 
 import Summoner.Config (ConfigP (..), PartialConfig, configT)
-import Summoner.License (License (..), licenseNames)
+import Summoner.License (LicenseName)
 import Summoner.ProjectData (CustomPrelude (..), GhcVer (..))
 import Test.DecisionSpec (genDecision)
 
@@ -31,8 +32,8 @@ genGhcVerArr = Gen.list (Range.constant 0 10) Gen.enumBounded
 genCustomPrelude :: MonadGen m => m CustomPrelude
 genCustomPrelude = Prelude <$> genText <*> genText
 
-genLicense :: MonadGen m => m License
-genLicense = Gen.element licenseNames
+genLicense :: MonadGen m => m LicenseName
+genLicense = Gen.element universe
 
 genPartialConfig :: MonadGen m => m PartialConfig
 genPartialConfig = do