diff --git a/src/Headroom/Command/Run.hs b/src/Headroom/Command/Run.hs index 4ecd9d9..537ab75 100644 --- a/src/Headroom/Command/Run.hs +++ b/src/Headroom/Command/Run.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} @@ -200,10 +202,10 @@ commandRun opts = bootstrap (env' opts) (croDebug opts) $ do let isCheck = cRunMode == Check warnOnDryRun startTS <- liftIO getPOSIXTime - templates <- loadTemplates + templates <- loadTemplates @TemplateType sourceFiles <- findSourceFiles (M.keys templates) _ <- logInfo "-----" - (total, processed) <- processSourceFiles templates sourceFiles + (total, processed) <- processSourceFiles @TemplateType templates sourceFiles endTS <- liftIO getPOSIXTime when (processed > 0) $ logStickyDone "-----" logStickyDone $ mconcat @@ -239,7 +241,6 @@ findSourceFiles fileTypes = do files <- mconcat <$> mapM (fsFindFilesByTypes cLicenseHeaders fileTypes) cSourcePaths let files' = excludePaths cExcludedPaths files - -- Found logInfo $ mconcat [ "Found " , display $ length files' @@ -250,7 +251,9 @@ findSourceFiles fileTypes = do pure files' -processSourceFiles :: ( Has CtConfiguration env +processSourceFiles :: forall a env + . ( Template a + , Has CtConfiguration env , Has CtHeaderFnConfigs env , Has CommandRunOptions env , Has CurrentYear env @@ -264,16 +267,18 @@ processSourceFiles templates paths = do year <- viewL let dVars = dynamicVariables year withTemplate = mapMaybe (template cLicenseHeaders) paths - cVars <- compileVariables (dVars <> cVariables) + cVars <- compileVariables @a (dVars <> cVariables) processed <- mapM (process cVars dVars) (zipWithProgress withTemplate) pure (length withTemplate, length . filter (== True) $ processed) where fileType c p = fileExtension p >>= fileTypeByExt c template c p = (, p) <$> (fileType c p >>= \ft -> M.lookup ft templates) - process cVars dVars (pr, (ht, p)) = processSourceFile cVars dVars pr ht p + process cVars dVars (pr, (ht, p)) = processSourceFile @a cVars dVars pr ht p -processSourceFile :: ( Has CommandRunOptions env +processSourceFile :: forall a env + . ( Template a + , Has CommandRunOptions env , Has CtConfiguration env , Has CtHeaderFnConfigs env , Has CurrentYear env @@ -295,7 +300,7 @@ processSourceFile cVars dVars progress ht@HeaderTemplate {..} path = do variables = dVars <> cVars <> hiVariables syntax = hcHeaderSyntax hiHeaderConfig header' <- renderTemplate variables htTemplate - header <- postProcessHeader' syntax variables header' + header <- postProcessHeader' @a syntax variables header' RunAction {..} <- chooseAction headerInfo header let result = raFunc source changed = raProcessed && (source /= result) @@ -344,7 +349,11 @@ chooseAction info header = do -- | Loads templates from the given paths. -loadTemplateFiles :: (Has (FileSystem (RIO env)) env, HasLogFunc env) +loadTemplateFiles :: forall a env + . ( Template a + , Has (FileSystem (RIO env)) env + , HasLogFunc env + ) => [FilePath] -- ^ paths to template files -> RIO env (Map FileType TemplateType) @@ -361,7 +370,7 @@ loadTemplateFiles paths' = do withTypes logInfo $ mconcat ["Found ", display $ length parsed, " license templates"] pure $ M.fromList parsed - where extensions = toList $ templateExtensions @TemplateType + where extensions = toList $ templateExtensions @a -- | Loads built-in templates, stored in "Headroom.Embedded", for the given @@ -380,7 +389,9 @@ loadBuiltInTemplates licenseType = do template = licenseTemplate licenseType -loadTemplates :: ( Has CtConfiguration env +loadTemplates :: forall a env + . ( Template a + , Has CtConfiguration env , Has (FileSystem (RIO env)) env , HasLogFunc env ) @@ -388,7 +399,7 @@ loadTemplates :: ( Has CtConfiguration env loadTemplates = do Configuration {..} <- viewL @CtConfiguration templates <- case cTemplateSource of - TemplateFiles paths -> loadTemplateFiles paths + TemplateFiles paths -> loadTemplateFiles @a paths BuiltInTemplates licenseType -> loadBuiltInTemplates licenseType pure $ M.mapWithKey (extractHeaderTemplate cLicenseHeaders) templates @@ -473,7 +484,11 @@ currentYear = do -- -- 1. sanitize possibly corrupted comment syntax ('sanitizeSyntax') -- 2. apply /license header functions/ ('postProcessHeader') -postProcessHeader' :: (Has CtHeaderFnConfigs env, Has CurrentYear env) +postProcessHeader' :: forall a env + . ( Template a + , Has CtHeaderFnConfigs env + , Has CurrentYear env + ) => HeaderSyntax -- ^ syntax of the license header comments -> Variables @@ -485,5 +500,5 @@ postProcessHeader' :: (Has CtHeaderFnConfigs env, Has CurrentYear env) postProcessHeader' syntax vars rawHeader = do configs <- viewL @CtHeaderFnConfigs year <- viewL - cEnv <- mkConfiguredEnv year vars configs + cEnv <- mkConfiguredEnv @a year vars configs pure . sanitizeSyntax syntax . postProcessHeader cEnv $ rawHeader diff --git a/src/Headroom/HeaderFn.hs b/src/Headroom/HeaderFn.hs index d4741ac..472670a 100644 --- a/src/Headroom/HeaderFn.hs +++ b/src/Headroom/HeaderFn.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -5,6 +6,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -48,7 +50,6 @@ import Headroom.HeaderFn.UpdateCopyright ( SelectedAuthors(..) , UpdateCopyrightMode(..) , updateCopyright ) -import Headroom.Meta ( TemplateType ) import Headroom.Template ( Template(..) ) import Headroom.Types ( CurrentYear(..) ) import Headroom.Variables.Types ( Variables(..) ) @@ -125,7 +126,8 @@ instance Has UpdateCopyrightMode ConfiguredEnv where -- | Constructor function for 'ConfiguredEnv' data type. This function takes -- 'Variables' as argument, because it performs template compilation on -- selected fields of 'CtHeaderFnConfigs'. -mkConfiguredEnv :: (MonadThrow m) +mkConfiguredEnv :: forall a m + . (Template a, MonadThrow m) => CurrentYear -- ^ current year -> Variables @@ -135,7 +137,7 @@ mkConfiguredEnv :: (MonadThrow m) -> m ConfiguredEnv -- ^ environment data type mkConfiguredEnv ceCurrentYear vars configs = do - ceHeaderFnConfigs <- compileTemplates vars configs + ceHeaderFnConfigs <- compileTemplates @a vars configs let ceUpdateCopyrightMode = mode ceHeaderFnConfigs pure ConfiguredEnv { .. } where @@ -147,7 +149,8 @@ mkConfiguredEnv ceCurrentYear vars configs = do ------------------------------ PRIVATE FUNCTIONS ----------------------------- -compileTemplates :: (MonadThrow m) +compileTemplates :: forall a m + . (Template a, MonadThrow m) => Variables -> CtHeaderFnConfigs -> m CtHeaderFnConfigs @@ -156,7 +159,7 @@ compileTemplates vars configs = configs & traverseOf authorsL compileAuthors' authorsL = hfcsUpdateCopyrightL . hfcConfigL . uccSelectedAuthorsL compileAuthors' = mapM . mapM $ compileAuthor compileAuthor author = do - parsed <- parseTemplate @TemplateType (Just $ "author " <> author) author + parsed <- parseTemplate @a (Just $ "author " <> author) author renderTemplate vars parsed diff --git a/src/Headroom/Template/TemplateRef.hs b/src/Headroom/Template/TemplateRef.hs index e187a71..90707d6 100644 --- a/src/Headroom/Template/TemplateRef.hs +++ b/src/Headroom/Template/TemplateRef.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-| Module : Headroom.Template.TemplateRef @@ -36,7 +38,6 @@ import Headroom.Data.Regex ( match , re ) import Headroom.FileType.Types ( FileType ) -import Headroom.Meta ( TemplateType ) import Headroom.Template ( Template(..) ) import Headroom.Types ( fromHeadroomError , toHeadroomError @@ -72,12 +73,17 @@ data TemplateRef = TemplateRef -- valid URL with either @http@ or @https@ as protocol, it considers it as -- 'UriTemplateSource', otherwise it creates 'LocalTemplateSource'. -- --- >>> mkTemplateRef "/path/to/haskell.mustache" :: Maybe TemplateRef +-- >>> :set -XTypeApplications +-- >>> import Headroom.Template.Mustache (Mustache) +-- >>> mkTemplateRef @Mustache "/path/to/haskell.mustache" :: Maybe TemplateRef -- Just (TemplateRef {trFileType = Haskell, trSource = LocalTemplateSource "/path/to/haskell.mustache"}) -- --- >>> mkTemplateRef "https://foo.bar/haskell.mustache" :: Maybe TemplateRef +-- >>> :set -XTypeApplications +-- >>> import Headroom.Template.Mustache (Mustache) +-- >>> mkTemplateRef @Mustache "https://foo.bar/haskell.mustache" :: Maybe TemplateRef -- Just (TemplateRef {trFileType = Haskell, trSource = UriTemplateSource (URI {uriScheme = Just "https", uriAuthority = Right (Authority {authUserInfo = Nothing, authHost = "foo.bar", authPort = Nothing}), uriPath = Just (False,"haskell.mustache" :| []), uriQuery = [], uriFragment = Nothing})}) -mkTemplateRef :: MonadThrow m +mkTemplateRef :: forall a m + . (Template a, MonadThrow m) => Text -- ^ input text -> m TemplateRef -- ^ created 'TemplateRef' (or error) mkTemplateRef raw = do @@ -85,7 +91,7 @@ mkTemplateRef raw = do source <- detectSource pure TemplateRef { trFileType = fileType, trSource = source } where - exts = templateExtensions @TemplateType + exts = templateExtensions @a detectSource = case match [re|(^\w+):\/\/|] raw of Just (_ : p : _) | p `elem` ["http", "https"] -> UriTemplateSource <$> mkURI raw diff --git a/src/Headroom/Variables.hs b/src/Headroom/Variables.hs index bd92a86..df0137c 100644 --- a/src/Headroom/Variables.hs +++ b/src/Headroom/Variables.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} {-| Module : Headroom.Variables @@ -29,7 +31,6 @@ module Headroom.Variables where import Data.String.Interpolate ( iii ) -import Headroom.Meta ( TemplateType ) import Headroom.Template ( Template(..) ) import Headroom.Types ( CurrentYear(..) , fromHeadroomError @@ -84,11 +85,14 @@ parseVariables variables = fmap mkVariables (mapM parse variables) -- Note that recursive variable reference and/or cyclic references are not -- supported. -- --- >>> let compiled = compileVariables $ mkVariables [("name", "John"), ("msg", "Hello, {{ name }}")] +-- >>> :set -XTypeApplications +-- >>> import Headroom.Template.Mustache (Mustache) +-- >>> let compiled = compileVariables @Mustache $ mkVariables [("name", "John"), ("msg", "Hello, {{ name }}")] -- >>> let expected = mkVariables [("name", "John"), ("msg", "Hello, John")] -- >>> compiled == Just expected -- True -compileVariables :: (MonadThrow m) +compileVariables :: forall a m + . (Template a, MonadThrow m) => Variables -- ^ input variables to compile -> m Variables @@ -98,7 +102,7 @@ compileVariables variables@(Variables kvs) = do pure $ mkVariables compiled where compileVariable (key, value) = do - parsed <- parseTemplate @TemplateType (Just $ "variable " <> key) value + parsed <- parseTemplate @a (Just $ "variable " <> key) value rendered <- renderTemplate variables parsed pure (key, rendered) diff --git a/test/Headroom/Command/RunSpec.hs b/test/Headroom/Command/RunSpec.hs index 36c0531..7eb085c 100644 --- a/test/Headroom/Command/RunSpec.hs +++ b/test/Headroom/Command/RunSpec.hs @@ -34,6 +34,7 @@ import Headroom.FileType.Types ( FileType(..) ) import Headroom.IO.FileSystem ( FileSystem(..) ) import Headroom.Meta ( TemplateType ) import Headroom.Template ( Template(..) ) +import Headroom.Template.Mustache ( Mustache ) import Headroom.Types ( CurrentYear(..) ) import Headroom.Variables ( mkVariables ) import RIO hiding ( assert ) @@ -86,7 +87,7 @@ spec = do fsFindFilesByExts' _ _ = throwString "INVALID CONDITION" fsLoadFile' "haskell.mustache" = pure "template content" fsLoadFile' _ = throwString "INVALID CONDITION" - templates <- runRIO env' $ loadTemplateFiles ["test-dir"] + templates <- runRIO env' $ loadTemplateFiles @Mustache ["test-dir"] M.size templates `shouldBe` 1 M.member Haskell templates `shouldBe` True @@ -115,7 +116,8 @@ spec = do ] vars = mkVariables [("sndAuthor", "2nd Author")] syntax = LineComment [re|^--|] (Just "--") - runRIO env (postProcessHeader' syntax vars sample) `shouldReturn` expected + runRIO env (postProcessHeader' @Mustache syntax vars sample) + `shouldReturn` expected env :: TestEnv diff --git a/test/Headroom/HeaderFnSpec.hs b/test/Headroom/HeaderFnSpec.hs index 9419f26..d711615 100644 --- a/test/Headroom/HeaderFnSpec.hs +++ b/test/Headroom/HeaderFnSpec.hs @@ -2,7 +2,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} + module Headroom.HeaderFnSpec ( spec ) @@ -17,6 +19,7 @@ import Headroom.Data.Text ( fromLines ) import Headroom.HeaderFn import Headroom.HeaderFn.Types import Headroom.HeaderFn.UpdateCopyright +import Headroom.Template.Mustache ( Mustache ) import Headroom.Types ( CurrentYear(..) ) import Headroom.Variables ( mkVariables ) import RIO @@ -71,8 +74,8 @@ spec = do describe "mkConfiguredEnv" $ do it "makes ConfiguredEnv from input parameters" $ do let configsIn = configs "{{ sndAuthor }}" - envOut = configuredEnv "2nd Author" - mkConfiguredEnv currentYear vars configsIn `shouldBe` Just envOut + out = configuredEnv "2nd Author" + mkConfiguredEnv @Mustache currentYear vars configsIn `shouldBe` Just out ------------------------------- Test Data Types ------------------------------ diff --git a/test/Headroom/Template/TemplateRefSpec.hs b/test/Headroom/Template/TemplateRefSpec.hs index 09fa26f..c86a956 100644 --- a/test/Headroom/Template/TemplateRefSpec.hs +++ b/test/Headroom/Template/TemplateRefSpec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} module Headroom.Template.TemplateRefSpec ( spec @@ -10,6 +11,7 @@ where import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Template.Mustache ( Mustache ) import Headroom.Template.TemplateRef import RIO import Test.Hspec @@ -26,7 +28,7 @@ spec = do { trFileType = Haskell , trSource = LocalTemplateSource "/path/to/some/haskell.mustache" } - mkTemplateRef raw `shouldBe` Just expected + mkTemplateRef @Mustache raw `shouldBe` Just expected it "creates valid reference to HTTP Haskell template" $ do let raw = "http://foo/haskell.mustache" @@ -34,11 +36,11 @@ spec = do { trFileType = Haskell , trSource = UriTemplateSource [uri|http://foo/haskell.mustache|] } - mkTemplateRef raw `shouldBe` Just expected + mkTemplateRef @Mustache raw `shouldBe` Just expected it "throws error if URI is valid but protocol is not supported" $ do let raw = "foo://foo/haskell.mustache" - mkTemplateRef raw `shouldThrow` \case + mkTemplateRef @Mustache raw `shouldThrow` \case (UnsupportedUriProtocol _ _) -> True _ -> False diff --git a/test/Headroom/VariablesSpec.hs b/test/Headroom/VariablesSpec.hs index 9f2d81a..da18806 100644 --- a/test/Headroom/VariablesSpec.hs +++ b/test/Headroom/VariablesSpec.hs @@ -1,10 +1,13 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + module Headroom.VariablesSpec ( spec ) where +import Headroom.Template.Mustache ( Mustache ) import Headroom.Types ( CurrentYear(..) ) import Headroom.Variables import Headroom.Variables.Types ( Variables(..) ) @@ -36,12 +39,12 @@ spec = do [("name", "John Smith"), ("greeting", "Hello, {{ name }}")] expected = mkVariables [("name", "John Smith"), ("greeting", "Hello, John Smith")] - compileVariables sample1 `shouldReturn` expected + compileVariables @Mustache sample1 `shouldReturn` expected it "doesn't get stuck in infinite loop on invalid recursive variable" $ do let sample1 = mkVariables [("greeting", "Hello, {{ greeting }}")] expected = mkVariables [("greeting", "Hello, Hello, {{ greeting }}")] - compileVariables sample1 `shouldReturn` expected + compileVariables @Mustache sample1 `shouldReturn` expected describe "dynamicVariables" $ do