Skip to content

Commit

Permalink
[#66] Extend the TemplateRef concept
Browse files Browse the repository at this point in the history
  • Loading branch information
@vaclavsvejcar
vaclavsvejcar committed Apr 15, 2021
1 parent 1a7d70a commit 9c83ad6
Show file tree
Hide file tree
Showing 13 changed files with 134 additions and 124 deletions.
4 changes: 1 addition & 3 deletions src/Headroom/Command/Readers.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -31,7 +31,6 @@ import Headroom.Data.Regex ( Regex(..)
, compile
)
import Headroom.FileType.Types ( FileType(..) )
import Headroom.Meta ( TemplateType )
import Headroom.Template.TemplateRef ( TemplateRef(..)
, mkTemplateRef
)
Expand Down Expand Up @@ -77,8 +76,7 @@ regexReader =
-- | Reader for 'TemplateRef'.
templateRefReader :: ReadM TemplateRef
templateRefReader =
let parse input = mapLeft displayException
(mkTemplateRef @TemplateType . T.pack $ input)
let parse input = mapLeft displayException (mkTemplateRef . T.pack $ input)
in eitherReader parse


Expand Down
48 changes: 30 additions & 18 deletions src/Headroom/Command/Run.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
Expand Down Expand Up @@ -35,6 +36,7 @@ module Headroom.Command.Run
)
where

import Data.String.Interpolate ( i )
import Data.Time.Calendar ( toGregorian )
import Data.Time.Clock ( getCurrentTime )
import Data.Time.Clock.POSIX ( getPOSIXTime )
Expand Down Expand Up @@ -360,24 +362,28 @@ loadTemplateRefs :: forall a env
=> [TemplateRef] -- ^ template references
-> RIO env (Map FileType a) -- ^ map of templates
loadTemplateRefs refs = do
fs <- viewL
n <- viewL
allRefs <- concat <$> mapM (getAllRefs fs) refs
refsWTp <- (\rs -> [ (ft, ref) | (Just ft, ref) <- rs ]) <$> zipRs allRefs
refsWCtn <- mapM (loadContent fs n) (filterPreferred refsWTp)
fileSystem <- viewL
network <- viewL
allRefs <- concat <$> mapM (getAllRefs fileSystem) refs
refsWTp <- (\rs -> [ (ft, ref) | (Just ft, ref) <- rs ]) <$> zipRs allRefs
refsWCtn <- mapM (loadContent fileSystem network) (filterPreferred refsWTp)
M.fromList <$> mapM loadTemplate refsWCtn
where
zipRs = \rs -> fmap (`zip` rs) . mapM getFileType $ rs
exts = toList $ templateExtensions @a
getAllRefs = \fs ref -> case ref of
LocalTemplateRef p -> fmap LocalTemplateRef <$> fsFindFilesByExts fs p exts
UriTemplateRef _ -> pure [ref]
_ -> pure [ref]
loadContent = \fs n (ft, ref) -> (ft, ref, ) <$> case ref of
LocalTemplateRef path -> fsLoadFile fs path
UriTemplateRef uri -> nDownloadContent n uri
loadTemplate =
\(ft, ref, c) -> (ft, ) <$> parseTemplate @a (Just . renderRef $ ref) c
getFileType = typeOfTemplate . T.unpack . renderRef
InlineRef content -> pure content
LocalTemplateRef path -> fsLoadFile fs path
UriTemplateRef uri -> nDownloadContent n uri
BuiltInRef lt ft' -> pure $ licenseTemplate lt ft'
loadTemplate = \(ft, ref, c) -> (ft, ) <$> parseTemplate @a ref c
getFileType = \case
InlineRef _ -> pure Nothing
BuiltInRef _ ft -> pure . Just $ ft
other -> typeOfTemplate . T.unpack . renderRef $ other
filterPreferred rs =
mapMaybe (L.headMaybe . L.sort) . L.groupBy (\x y -> fst x == fst y) $ rs

Expand All @@ -389,7 +395,9 @@ loadBuiltInTemplates :: (HasLogFunc env)
-> RIO env (Map FileType TemplateType) -- ^ map of file types and templates
loadBuiltInTemplates licenseType = do
logInfo $ "Using built-in templates for license: " <> displayShow licenseType
parsed <- mapM (\(t, r) -> (t, ) <$> parseTemplate Nothing r) rawTemplates
parsed <- mapM
(\(t, r) -> (t, ) <$> parseTemplate (BuiltInRef licenseType t) r)
rawTemplates
pure $ M.fromList parsed
where
rawTemplates = fmap (\ft -> (ft, template ft)) (allValues @FileType)
Expand All @@ -404,12 +412,16 @@ loadTemplates :: ( Has CtConfiguration env
=> RIO env (Map FileType HeaderTemplate)
loadTemplates = do
Configuration {..} <- viewL @CtConfiguration
fromRefs <- loadTemplateRefs @TemplateType cTemplateRefs
builtIn <- case cBuiltInTemplates of
Just licenseType -> loadBuiltInTemplates licenseType
_ -> pure M.empty
pure $ M.mapWithKey (extractHeaderTemplate cLicenseHeaders)
(builtIn <> fromRefs)
let allRefs = builtInRefs cBuiltInTemplates <> cTemplateRefs
templates <- loadTemplateRefs @TemplateType allRefs
logInfo . display . T.intercalate "\n" . stats . M.toList $ templates
pure $ M.mapWithKey (extractHeaderTemplate cLicenseHeaders) templates
where
stats =
fmap (\(ft, t) -> [i|Using #{ft} template: #{renderRef . templateRef $ t}|])
builtInRefs = \case
Just lt -> fmap (BuiltInRef lt) $ allValues @FileType
_ -> []


-- | Takes path to the template file and returns detected type of the template.
Expand Down
29 changes: 2 additions & 27 deletions src/Headroom/Configuration/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -83,13 +83,13 @@ import Data.String.Interpolate ( i
, iii
)
import Generic.Data ( Generically(..) )
import Headroom.Data.EnumExtra ( EnumExtra(..) )
import Headroom.Data.Regex ( Regex(..) )
import Headroom.Data.Serialization ( aesonOptions )
import Headroom.FileType.Types ( FileType )
import Headroom.Meta ( webDocConfigCurr )
import Headroom.Template.TemplateRef ( TemplateRef )
import Headroom.Types ( fromHeadroomError
import Headroom.Types ( LicenseType(..)
, fromHeadroomError
, toHeadroomError
)
import Headroom.Variables.Types ( Variables(..) )
Expand Down Expand Up @@ -148,31 +148,6 @@ instance FromJSON LineComment' where
parseJSON = genericParseJSON aesonOptions


--------------------------------- LicenseType --------------------------------

-- | Supported type of open source license.
data LicenseType
= Apache2
-- ^ support for /Apache-2.0/ license
| BSD3
-- ^ support for /BSD-3-Clause/ license
| GPL2
-- ^ support for /GNU GPL2/ license
| GPL3
-- ^ support for /GNU GPL3/ license
| MIT
-- ^ support for /MIT/ license
| MPL2
-- ^ support for /MPL2/ license
deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show)

instance FromJSON LicenseType where
parseJSON = \case
String s -> case textToEnum s of
Just licenseType -> pure licenseType
_ -> error $ "Unknown license type: " <> T.unpack s
other -> error $ "Invalid value for run mode: " <> show other

----------------------------------- RunMode ----------------------------------

-- | Represents what action should the @run@ command perform.
Expand Down
3 changes: 2 additions & 1 deletion src/Headroom/HeaderFn.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -51,6 +51,7 @@ import Headroom.HeaderFn.UpdateCopyright ( SelectedAuthors(..)
, updateCopyright
)
import Headroom.Template ( Template(..) )
import Headroom.Template.TemplateRef ( TemplateRef(..) )
import Headroom.Types ( CurrentYear(..) )
import Headroom.Variables.Types ( Variables(..) )
import Lens.Micro ( traverseOf )
Expand Down Expand Up @@ -159,7 +160,7 @@ compileTemplates vars configs = configs & traverseOf authorsL compileAuthors'
authorsL = hfcsUpdateCopyrightL . hfcConfigL . uccSelectedAuthorsL
compileAuthors' = mapM . mapM $ compileAuthor
compileAuthor author = do
parsed <- parseTemplate @a (Just $ "author " <> author) author
parsed <- parseTemplate @a (InlineRef author) author
renderTemplate vars parsed


Expand Down
39 changes: 16 additions & 23 deletions src/Headroom/Template.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,6 +29,7 @@ module Headroom.Template
where

import Data.String.Interpolate ( iii )
import Headroom.Template.TemplateRef ( TemplateRef(..) )
import Headroom.Types ( fromHeadroomError
, toHeadroomError
)
Expand All @@ -41,53 +42,45 @@ import qualified RIO.Text as T
class Template a where

-- | Returns list of supported file extensions for this template type.
templateExtensions :: NonEmpty Text
-- ^ list of supported file extensions
templateExtensions :: NonEmpty Text -- ^ list of supported file extensions


-- | Parses template from given raw text.
parseTemplate :: MonadThrow m
=> Maybe Text
-- ^ name of the template (optional)
-> Text
-- ^ raw template text
-> m a
-- ^ parsed template
=> TemplateRef -- ^ reference to template source
-> Text -- ^ raw template text
-> m a -- ^ parsed template


-- | Renders parsed template and replaces all variables with actual values.
renderTemplate :: MonadThrow m
=> Variables
-- ^ values of variables to replace
-> a
-- ^ parsed template to render
-> m Text
-- ^ rendered template text
=> Variables -- ^ values of variables to replace
-> a -- ^ parsed template to render
-> m Text -- ^ rendered template text


-- | Returns the raw text of the template, same that has been parsed by
-- 'parseTemplate' method.
rawTemplate :: a
-- ^ template for which to return raw template text
-> Text
-- ^ raw template text
rawTemplate :: a -- ^ template for which to return raw template text
-> Text -- ^ raw template text


templateRef :: a -> TemplateRef


------------------------------ PUBLIC FUNCTIONS ------------------------------

-- | Returns empty template of selected type.
emptyTemplate :: (MonadThrow m, Template a) => m a
emptyTemplate = parseTemplate Nothing T.empty
emptyTemplate = parseTemplate (InlineRef T.empty) T.empty


--------------------------------- ERROR TYPES --------------------------------

-- | Error during processing template.
data TemplateError
= MissingVariables Text [Text]
-- ^ missing variable values
| ParseError Text
-- ^ error parsing raw template text
= MissingVariables Text [Text] -- ^ missing variable values
| ParseError Text -- ^ error parsing raw template text
deriving (Eq, Show, Typeable)


Expand Down
17 changes: 11 additions & 6 deletions src/Headroom/Template/Mustache.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,9 @@ where
import Headroom.Template ( Template(..)
, TemplateError(..)
)
import Headroom.Template.TemplateRef ( TemplateRef
, renderRef
)
import Headroom.Variables.Types ( Variables(..) )
import RIO
import qualified RIO.Text as T
Expand All @@ -35,6 +38,7 @@ import Text.Mustache.Render ( SubstitutionError(..) )
data Mustache = Mustache
{ mCompiledTemplate :: MU.Template
, mRawTemplate :: Text
, mTemplateRef :: TemplateRef
}
deriving Show

Expand All @@ -48,17 +52,18 @@ instance Template Mustache where
parseTemplate = parseTemplate'
renderTemplate = renderTemplate'
rawTemplate = mRawTemplate
templateRef = mTemplateRef


parseTemplate' :: MonadThrow m => Maybe Text -> Text -> m Mustache
parseTemplate' name raw = case MU.compileTemplate templateName raw of
Left err -> throwM . ParseError $ tshow err
Right res -> pure $ Mustache res raw
where templateName = T.unpack . fromMaybe T.empty $ name
parseTemplate' :: MonadThrow m => TemplateRef -> Text -> m Mustache
parseTemplate' ref raw =
case MU.compileTemplate (T.unpack $ renderRef ref) raw of
Left err -> throwM . ParseError $ tshow err
Right res -> pure $ Mustache res raw ref


renderTemplate' :: MonadThrow m => Variables -> Mustache -> m Text
renderTemplate' (Variables variables) (Mustache t@(MU.Template name _ _) _) =
renderTemplate' (Variables variables) (Mustache t@(MU.Template name _ _) _ _) =
case MU.checkedSubstitute t variables of
([], rendered) -> pure rendered
(errs, rendered) ->
Expand Down
37 changes: 17 additions & 20 deletions src/Headroom/Template/TemplateRef.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
Expand Down Expand Up @@ -39,15 +38,16 @@ where
import Data.Aeson ( FromJSON(..)
, Value(String)
)
import Data.String.Interpolate ( iii )
import Data.String.Interpolate ( i
, iii
)
import Headroom.Data.EnumExtra ( textToEnum )
import Headroom.Data.Regex ( match
, re
)
import Headroom.FileType.Types ( FileType(..) )
import Headroom.Meta ( TemplateType )
import Headroom.Template ( Template(..) )
import Headroom.Types ( fromHeadroomError
import Headroom.Types ( LicenseType
, fromHeadroomError
, toHeadroomError
)
import RIO
Expand All @@ -62,14 +62,16 @@ import qualified Text.URI as URI

-- | Reference to the template (e.g. local file, URI address).
data TemplateRef
= LocalTemplateRef FilePath -- ^ template path on local file system
= InlineRef Text
| LocalTemplateRef FilePath -- ^ template path on local file system
| UriTemplateRef URI -- ^ remote template URI adress
| BuiltInRef LicenseType FileType
deriving (Eq, Ord, Show)


instance FromJSON TemplateRef where
parseJSON = \case
String s -> maybe (error $ T.unpack s) pure (mkTemplateRef @TemplateType s)
String s -> maybe (error $ T.unpack s) pure (mkTemplateRef s)
other -> error $ "Invalid value for template reference: " <> show other


Expand All @@ -79,17 +81,12 @@ instance FromJSON TemplateRef where
-- valid URL with either @http@ or @https@ as protocol, it considers it as
-- 'UriTemplateRef', otherwise it creates 'LocalTemplateRef'.
--
-- >>> :set -XTypeApplications
-- >>> import Headroom.Template.Mustache (Mustache)
-- >>> mkTemplateRef @Mustache "/path/to/haskell.mustache" :: Maybe TemplateRef
-- >>> mkTemplateRef "/path/to/haskell.mustache" :: Maybe TemplateRef
-- Just (LocalTemplateRef "/path/to/haskell.mustache")
--
-- >>> :set -XTypeApplications
-- >>> import Headroom.Template.Mustache (Mustache)
-- >>> mkTemplateRef @Mustache "https://foo.bar/haskell.mustache" :: Maybe TemplateRef
-- >>> mkTemplateRef "https://foo.bar/haskell.mustache" :: Maybe TemplateRef
-- Just (UriTemplateRef (URI {uriScheme = Just "https", uriAuthority = Right (Authority {authUserInfo = Nothing, authHost = "foo.bar", authPort = Nothing}), uriPath = Just (False,"haskell.mustache" :| []), uriQuery = [], uriFragment = Nothing}))
mkTemplateRef :: forall a m
. (Template a, MonadThrow m)
mkTemplateRef :: MonadThrow m
=> Text -- ^ input text
-> m TemplateRef -- ^ created 'TemplateRef' (or error)
mkTemplateRef raw = case match [re|(^\w+):\/\/|] raw of
Expand All @@ -98,10 +95,8 @@ mkTemplateRef raw = case match [re|(^\w+):\/\/|] raw of
_ -> pure . LocalTemplateRef . T.unpack $ raw
where
uriTemplateRef = extractFileType >> UriTemplateRef <$> mkURI raw
exts = templateExtensions @a
extractFileType = case match [re|(\w+)\.(\w+)$|] raw of
Just (_ : (textToEnum @FileType -> (Just ft )) : e : _) | e `elem` exts ->
pure ft
Just (_ : (textToEnum @FileType -> (Just ft )) : _ : _) -> pure ft
_ -> throwM $ UnrecognizedTemplateName raw


Expand All @@ -110,8 +105,10 @@ mkTemplateRef raw = case match [re|(^\w+):\/\/|] raw of
-- | Renders given 'TemplateRef' into human-friendly text.
renderRef :: TemplateRef -- ^ 'TemplateRef' to render
-> Text -- ^ rendered text
renderRef (LocalTemplateRef path) = T.pack path
renderRef (UriTemplateRef uri ) = URI.render uri
renderRef (InlineRef content) = [i|<inline template '#{content}'>|]
renderRef (LocalTemplateRef path ) = T.pack path
renderRef (UriTemplateRef uri ) = URI.render uri
renderRef (BuiltInRef lt ft ) = [i|<built-in template #{lt}/#{ft}>|]


--------------------------------- ERROR TYPES --------------------------------
Expand Down
Loading

0 comments on commit 9c83ad6

Please sign in to comment.