[#66] Remove hardcoded TemplateType where possible

vaclavsvejcar · Apr 15, 2021 · 40e3a9c · 40e3a9c
1 parent f681909
commit 40e3a9c
Show file tree

Hide file tree

Showing 8 changed files with 88 additions and 50 deletions.
diff --git 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,15 +389,17 @@ 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
                  )
               => RIO env (Map FileType HeaderTemplate)
 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
@@ -1,10 +1,12 @@
+{-# LANGUAGE AllowAmbiguousTypes   #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# 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
@@ -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,20 +73,25 @@ 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
   fileType <- extractFileType
   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
@@ -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
@@ -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
@@ -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  ------------------------------