content: {-# LANGUAGE NoImplicitPrelude #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  {-|
  Module      : Stack.Types.TemplateName
  Description : Template name handling.
  License     : BSD-3-Clause
  
  Template name handling.
  -}
  
  module Stack.Types.TemplateName
    ( TemplateName
    , RepoTemplatePath (..)
    , RepoService (..)
    , TemplatePath (..)
    , templateName
    , templatePath
    , parseTemplateNameFromString
    , parseRepoPathWithService
    , templateNameArgument
    , templateParamArgument
    , defaultTemplateName
    ) where
  
  import           Data.Aeson ( FromJSON (..), withText )
  import qualified Data.Text as T
  import           Network.HTTP.StackClient ( parseRequest )
  import qualified Options.Applicative as O
  import           Path ( parseAbsFile, parseRelFile )
  import           Stack.Prelude
  
  -- | Type representing exceptions thrown by functions exported by the
  -- "Stack.Types.TemplateName" module.
  newtype TypeTemplateNameException
    = DefaultTemplateNameNotParsedBug String
    deriving Show
  
  instance Exception TypeTemplateNameException where
    displayException (DefaultTemplateNameNotParsedBug s) = bugReport "[S-7410]" $
      "Cannot parse default template name: "
      ++ s
  
  -- | A template name.
  data TemplateName
    = TemplateName !Text !TemplatePath
    deriving (Eq, Ord, Show)
  
  data TemplatePath
    = AbsPath (Path Abs File)
      -- ^ an absolute path on the filesystem
    | RelPath String (Path Rel File)
      -- ^ a relative path on the filesystem, or relative to the template
      -- repository. To avoid path separator conversion on Windows, the raw
      -- command-line parameter passed is also given as the first field (possibly
      -- with @.hsfiles@ appended).
    | UrlPath String
      -- ^ a full URL
    | RepoPath RepoTemplatePath
    deriving (Eq, Ord, Show)
  
  -- | Details for how to access a template from a remote repo.
  data RepoTemplatePath = RepoTemplatePath
    { service  :: RepoService
    , user     :: Text
    , template :: Text
    }
    deriving (Eq, Ord, Show)
  
  -- | Services from which templates can be retrieved from a repository.
  data RepoService
    = GitHub
    | GitLab
    | Bitbucket
    | Codeberg
    deriving (Eq, Ord, Show)
  
  instance FromJSON TemplateName where
    parseJSON = withText "TemplateName" $
      either fail pure . parseTemplateNameFromString . T.unpack
  
  -- | An argument which accepts a template name of the format @foo.hsfiles@ or
  -- @foo@, ultimately normalized to @foo@.
  templateNameArgument ::
       O.Mod O.ArgumentFields TemplateName
    -> O.Parser TemplateName
  templateNameArgument =
    O.argument
      (do s <- O.str
          either O.readerError pure (parseTemplateNameFromString s))
  
  -- | An argument which accepts a @key:value@ pair for specifying parameters.
  templateParamArgument ::
       O.Mod O.OptionFields (Text,Text)
    -> O.Parser (Text,Text)
  templateParamArgument =
    O.option
      (do s <- O.str
          either O.readerError pure (parsePair s))
   where
    parsePair :: String -> Either String (Text, Text)
    parsePair s =
      case break (==':') s of
        (key,':':value@(_:_)) -> Right (T.pack key, T.pack value)
        _ -> Left ("Expected key:value format for argument: " <> s)
  
  -- | Parse a template name from a string.
  parseTemplateNameFromString :: String -> Either String TemplateName
  parseTemplateNameFromString fname =
    case T.stripSuffix ".hsfiles" (T.pack fname) of
      Nothing -> parseValidFile (T.pack fname) (fname <> ".hsfiles") fname
      Just prefix -> parseValidFile prefix fname fname
   where
    parseValidFile prefix hsf orig =
      maybe (Left expected) Right $ asum (validParses prefix hsf orig)
    validParses prefix hsf orig =
      -- NOTE: order is important
      [ TemplateName prefix        . RepoPath <$> parseRepoPath hsf
      , TemplateName (T.pack orig) . UrlPath <$> (parseRequest orig *> Just orig)
      , TemplateName prefix        . AbsPath <$> parseAbsFile hsf
      , TemplateName prefix        . RelPath hsf <$> parseRelFile hsf
      ]
    expected = "Expected a template like: foo or foo.hsfiles or \
               \https://example.com/foo.hsfiles or github:user/foo"
  
  -- | The default template name you can use if you don't have one.
  defaultTemplateName :: TemplateName
  defaultTemplateName =
    case parseTemplateNameFromString "new-template" of
      Left s -> impureThrow $ DefaultTemplateNameNotParsedBug s
      Right x -> x
  
  -- | Get a text representation of the template name.
  templateName :: TemplateName -> Text
  templateName (TemplateName prefix _) = prefix
  
  -- | Get the path of the template.
  templatePath :: TemplateName -> TemplatePath
  templatePath (TemplateName _ fp) = fp
  
  defaultRepoUserForService :: RepoService -> Maybe Text
  defaultRepoUserForService GitHub = Just "commercialhaskell"
  defaultRepoUserForService _      = Nothing
  
  -- | Parses a template path of the form @github:user/template@.
  parseRepoPath :: String -> Maybe RepoTemplatePath
  parseRepoPath s =
    case T.splitOn ":" (T.pack s) of
      ["github"    , rest] -> parseRepoPathWithService GitHub rest
      ["gitlab"    , rest] -> parseRepoPathWithService GitLab rest
      ["bitbucket" , rest] -> parseRepoPathWithService Bitbucket rest
      ["codeberg"  , rest] -> parseRepoPathWithService Codeberg rest
      _                    -> Nothing
  
  -- | Parses a template path of the form @user/template@, given a service
  parseRepoPathWithService :: RepoService -> Text -> Maybe RepoTemplatePath
  parseRepoPathWithService service path =
    case T.splitOn "/" path of
      [user, name] -> Just $ RepoTemplatePath service user name
      [name] -> do
        repoUser <- defaultRepoUserForService service
        Just $ RepoTemplatePath service repoUser name
      _ -> Nothing
  