module Stack.Types.TemplateName where
import Data.Aeson.Extended (FromJSON, withText, parseJSON)
import Data.Aeson.Types (typeMismatch)
import qualified Data.Text as T
import Data.Yaml (Value(Object), (.:?))
import Language.Haskell.TH
import Network.HTTP.Client (parseRequest)
import qualified Options.Applicative as O
import Path
import Path.Internal
import Stack.Prelude
data TemplateName = TemplateName !Text !TemplatePath
deriving (Ord,Eq,Show)
data TemplatePath = AbsPath (Path Abs File)
| RelPath (Path Rel File)
| UrlPath String
deriving (Eq, Ord, Show)
instance FromJSON TemplateName where
parseJSON = withText "TemplateName" $
either fail return . parseTemplateNameFromString . T.unpack
data TemplateInfo = TemplateInfo
{ author :: Maybe Text
, description :: Maybe Text }
deriving (Eq, Ord, Show)
instance FromJSON TemplateInfo where
parseJSON (Object v) = TemplateInfo <$> v .:? "author" <*> v .:? "description"
parseJSON invalid = typeMismatch "Template Info" invalid
templateNameArgument :: O.Mod O.ArgumentFields TemplateName
-> O.Parser TemplateName
templateNameArgument =
O.argument
(do string <- O.str
either O.readerError return (parseTemplateNameFromString string))
templateParamArgument :: O.Mod O.OptionFields (Text,Text)
-> O.Parser (Text,Text)
templateParamArgument =
O.option
(do string <- O.str
either O.readerError return (parsePair string))
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)
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 =
[ TemplateName (T.pack orig) . UrlPath <$> (parseRequest orig *> Just orig)
, TemplateName prefix . AbsPath <$> parseAbsFile hsf
, TemplateName prefix . RelPath <$> parseRelFile hsf
]
expected = "Expected a template like: foo or foo.hsfiles or\
\ https://example.com/foo.hsfiles"
mkTemplateName :: String -> Q Exp
mkTemplateName s =
case parseTemplateNameFromString s of
Left{} -> runIO $ throwString ("Invalid template name: " ++ show s)
Right (TemplateName (T.unpack -> prefix) p) ->
[|TemplateName (T.pack prefix) $(pn)|]
where pn =
case p of
AbsPath (Path fp) -> [|AbsPath (Path fp)|]
RelPath (Path fp) -> [|RelPath (Path fp)|]
UrlPath fp -> [|UrlPath fp|]
templateName :: TemplateName -> Text
templateName (TemplateName prefix _) = prefix
templatePath :: TemplateName -> TemplatePath
templatePath (TemplateName _ fp) = fp