diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..631e802 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,286 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Format record definitions. This is disabled by default. + # + # You can control the layout of record fields. The only rules that can't be configured + # are these: + # + # - "|" is always aligned with "=" + # - "," in fields is always aligned with "{" + # - "}" is likewise always aligned with "{" + # + # - records: + # # How to format equals sign between type constructor and data constructor. + # # Possible values: + # # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the next line. + # equals: "indent 2" + # + # # How to format first field of each record constructor. + # # Possible values: + # # - "same_line" -- "{" and first field goes on the same line as the data constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + # first_field: "indent 2" + # + # # How many spaces to insert between the column with "," and the beginning of the comment in the next line. + # field_comment: 2 + # + # # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. + # deriving: 2 + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. All default to true. + - simple_align: + cases: true + top_level_patterns: true + records: true + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: global + + # The following options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_module_name: Import list is aligned `list_padding` spaces after + # the module name. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length) + # + # This is mainly intended for use with `pad_module_names: false`. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length, scanl, scanr, take, drop, + # sort, nub) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # Default: after_alias + list_align: after_alias + + # Right-pad the module names to align imports in a group: + # + # - true: a little more readable + # + # > import qualified Data.List as List (concat, foldl, foldr, + # > init, last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # - false: diff-safe + # + # > import qualified Data.List as List (concat, foldl, foldr, init, + # > last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # Default: true + pad_module_names: true + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with constructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # Align empty list (importing instances) + # + # Empty list align has following options + # + # - inherit: inherit list_align setting + # + # - right_after: () is right after the module name: + # + # > import Vector.Instances () + # + # Default: inherit + empty_list_align: inherit + + # List padding determines indentation of import list on lines after import. + # This option affects 'long_list_align'. + # + # - : constant value + # + # - module_name: align under start of module name. + # Useful for 'file' and 'group' align settings. + # + # Default: 4 + list_padding: 4 + + # Separate lists option affects formatting of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: true + + # Space surround option affects formatting of import lists on a single + # line. The only difference is single space after the initial + # parenthesis and a single space before the terminal parenthesis. + # + # - true: There is single space associated with the enclosing + # parenthesis. + # + # > import Data.Foo ( foo ) + # + # - false: There is no space associated with the enclosing parenthesis + # + # > import Data.Foo (foo) + # + # Default: false + space_surround: false + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-#LANGUAGE #-}'. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same column. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: true + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: false + + # Language prefix to be used for pragma declaration, this allows you to + # use other options non case-sensitive like "language" or "Language". + # If a non correct String is provided, it will default to: LANGUAGE. + language_prefix: LANGUAGE + + # Replace tabs by spaces. This is disabled by default. + # - tabs: + # # Number of spaces to use for each tab. Default: 8, as specified by the + # # Haskell report. + # spaces: 8 + + # Remove trailing whitespace + - trailing_whitespace: {} + + # Squash multiple spaces between the left and right hand sides of some + # elements into single spaces. Basically, this undoes the effect of + # simple_align but is a bit less conservative. + # - squash: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. +# +# Set this to null to disable all line wrapping. +# +# Default: 80. +columns: 80 + +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: native + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +# language_extensions: + # - TemplateHaskell + # - QuasiQuotes + +# Attempt to find the cabal file in ancestors of the current directory, and +# parse options (currently only language extensions) from that. +# +# Default: true +cabal: true diff --git a/src/Headroom/Command/Run.hs b/src/Headroom/Command/Run.hs index 537ab75..229b6d8 100644 --- a/src/Headroom/Command/Run.hs +++ b/src/Headroom/Command/Run.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} @@ -28,6 +29,7 @@ module Headroom.Command.Run ( commandRun , loadBuiltInTemplates , loadTemplateFiles + , loadTemplateRefs , typeOfTemplate -- * License Header Post-processing , postProcessHeader' @@ -88,6 +90,9 @@ import Headroom.IO.FileSystem ( FileSystem(..) , fileExtension , mkFileSystem ) +import Headroom.IO.Network ( Network(..) + , mkNetwork + ) import Headroom.Meta ( TemplateType , configFileName , productInfo @@ -96,6 +101,9 @@ import Headroom.SourceCode ( SourceCode , toText ) import Headroom.Template ( Template(..) ) +import Headroom.Template.TemplateRef ( TemplateRef(..) + , renderRef + ) import Headroom.Types ( CurrentYear(..) ) import Headroom.UI ( Progress(..) , zipWithProgress @@ -107,6 +115,7 @@ import Headroom.Variables ( compileVariables import Headroom.Variables.Types ( Variables(..) ) import RIO import RIO.FilePath ( takeBaseName ) +import qualified RIO.List as L import qualified RIO.Map as M import qualified RIO.Text as T @@ -116,37 +125,28 @@ suffixLensesFor ["cHeaderFnConfigs"] ''Configuration -- | Action to be performed based on the selected 'RunMode'. data RunAction = RunAction - { raProcessed :: Bool - -- ^ whether the given file was processed - , raFunc :: SourceCode -> SourceCode - -- ^ function to process the file - , raProcessedMsg :: Text - -- ^ message to show when file was processed - , raSkippedMsg :: Text - -- ^ message to show when file was skipped + { raProcessed :: Bool -- ^ whether the given file was processed + , raFunc :: SourceCode -> SourceCode -- ^ function to process the file + , raProcessedMsg :: Text -- ^ message to show when file was processed + , raSkippedMsg :: Text -- ^ message to show when file was skipped } -- | Initial /RIO/ startup environment for the /Run/ command. data StartupEnv = StartupEnv - { envLogFunc :: LogFunc - -- ^ logging function - , envRunOptions :: CommandRunOptions - -- ^ options + { envLogFunc :: LogFunc -- ^ logging function + , envRunOptions :: CommandRunOptions -- ^ options } suffixLenses ''StartupEnv -- | Full /RIO/ environment for the /Run/ command. data Env = Env - { envEnv :: StartupEnv - -- ^ startup /RIO/ environment - , envConfiguration :: CtConfiguration - -- ^ application configuration - , envCurrentYear :: CurrentYear - -- ^ current year - , envFileSystem :: FileSystem (RIO Env) - -- ^ file system operations + { envEnv :: StartupEnv -- ^ startup /RIO/ environment + , envConfiguration :: CtConfiguration -- ^ application configuration + , envCurrentYear :: CurrentYear -- ^ current year + , envNetwork :: Network (RIO Env) -- ^ network operations + , envFileSystem :: FileSystem (RIO Env) -- ^ file system operations } suffixLenses ''Env @@ -178,6 +178,9 @@ instance Has CommandRunOptions Env where instance Has CurrentYear Env where hasLens = envCurrentYearL +instance Has (Network (RIO Env)) Env where + hasLens = envNetworkL + instance Has (FileSystem (RIO Env)) Env where hasLens = envFileSystemL @@ -185,6 +188,7 @@ instance Has (FileSystem (RIO Env)) Env where env' :: CommandRunOptions -> LogFunc -> IO Env env' opts logFunc = do let envEnv = StartupEnv { envLogFunc = logFunc, envRunOptions = opts } + envNetwork = mkNetwork envFileSystem = mkFileSystem envConfiguration <- runRIO envEnv finalConfiguration envCurrentYear <- currentYear @@ -192,10 +196,8 @@ env' opts logFunc = do -- | Handler for /Run/ command. -commandRun :: CommandRunOptions - -- ^ /Run/ command options - -> IO () - -- ^ execution result +commandRun :: CommandRunOptions -- ^ /Run/ command options + -> IO () -- ^ execution result commandRun opts = bootstrap (env' opts) (croDebug opts) $ do CommandRunOptions {..} <- viewL Configuration {..} <- viewL @CtConfiguration @@ -348,6 +350,38 @@ chooseAction info header = do justify = T.justifyLeft 30 ' ' +-- | Loads templates using given template references. +loadTemplateRefs :: forall a env + . ( Template a + , Has (Network (RIO env)) env + , Has (FileSystem (RIO env)) env + , HasLogFunc 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) + 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] + 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 + filterPreferred rs = + mapMaybe (L.headMaybe . L.sort) . L.groupBy (\x y -> fst x == fst y) $ rs + + -- | Loads templates from the given paths. loadTemplateFiles :: forall a env . ( Template a diff --git a/src/Headroom/Template/TemplateRef.hs b/src/Headroom/Template/TemplateRef.hs index 26b1413..1fb836a 100644 --- a/src/Headroom/Template/TemplateRef.hs +++ b/src/Headroom/Template/TemplateRef.hs @@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-| Module : Headroom.Template.TemplateRef @@ -28,15 +29,20 @@ module Headroom.Template.TemplateRef TemplateRef(..) -- * Constructor Functions , mkTemplateRef + -- * Public Functions + , renderRef -- * Error Types , TemplateRefError(..) ) where import Data.String.Interpolate ( iii ) +import Headroom.Data.EnumExtra ( textToEnum ) import Headroom.Data.Regex ( match , re ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Template ( Template(..) ) import Headroom.Types ( fromHeadroomError , toHeadroomError ) @@ -45,6 +51,7 @@ import qualified RIO.Text as T import Text.URI ( URI(..) , mkURI ) +import qualified Text.URI as URI --------------------------------- DATA TYPES --------------------------------- @@ -62,18 +69,39 @@ data TemplateRef -- valid URL with either @http@ or @https@ as protocol, it considers it as -- 'UriTemplateRef', otherwise it creates 'LocalTemplateRef'. -- --- >>> mkTemplateRef "/path/to/haskell.mustache" :: Maybe TemplateRef +-- >>> :set -XTypeApplications +-- >>> import Headroom.Template.Mustache (Mustache) +-- >>> mkTemplateRef @Mustache "/path/to/haskell.mustache" :: Maybe TemplateRef -- Just (LocalTemplateRef "/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 (UriTemplateRef (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 = case match [re|(^\w+):\/\/|] raw of - Just (_ : p : _) | p `elem` ["http", "https"] -> UriTemplateRef <$> mkURI raw + Just (_ : p : _) | p `elem` ["http", "https"] -> uriTemplateRef | otherwise -> throwM $ UnsupportedUriProtocol p raw _ -> 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 + _ -> throwM $ UnrecognizedTemplateName raw + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | 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 --------------------------------- ERROR TYPES -------------------------------- diff --git a/test/Headroom/Command/RunSpec.hs b/test/Headroom/Command/RunSpec.hs index 7eb085c..7a99f5f 100644 --- a/test/Headroom/Command/RunSpec.hs +++ b/test/Headroom/Command/RunSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,6 +10,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Headroom.Command.RunSpec ( spec @@ -32,9 +34,11 @@ import Headroom.Data.Regex ( re ) import Headroom.Data.Text ( fromLines ) import Headroom.FileType.Types ( FileType(..) ) import Headroom.IO.FileSystem ( FileSystem(..) ) +import Headroom.IO.Network ( Network(..) ) import Headroom.Meta ( TemplateType ) import Headroom.Template ( Template(..) ) import Headroom.Template.Mustache ( Mustache ) +import Headroom.Template.TemplateRef ( TemplateRef(..) ) import Headroom.Types ( CurrentYear(..) ) import Headroom.Variables ( mkVariables ) import RIO hiding ( assert ) @@ -45,17 +49,20 @@ import Test.Hspec import Test.Hspec.QuickCheck ( prop ) import Test.QuickCheck hiding ( sample ) import Test.QuickCheck.Monadic +import Text.URI.QQ ( uri ) data TestEnv = TestEnv { envLogFunc :: LogFunc , envCurrentYear :: CurrentYear , envFileSystem :: FileSystem (RIO TestEnv) + , envNetwork :: Network (RIO TestEnv) , envHeaderFnConfigs :: CtHeaderFnConfigs } suffixLenses ''TestEnv suffixLensesFor ["fsFindFilesByExts", "fsLoadFile"] ''FileSystem +suffixLensesFor ["nDownloadContent"] ''Network instance HasLogFunc TestEnv where logFuncL = envLogFuncL @@ -69,6 +76,9 @@ instance Has CurrentYear TestEnv where instance Has (FileSystem (RIO TestEnv)) TestEnv where hasLens = envFileSystemL +instance Has (Network (RIO TestEnv)) TestEnv where + hasLens = envNetworkL + spec :: Spec spec = do @@ -92,6 +102,35 @@ spec = do M.member Haskell templates `shouldBe` True + describe "loadTemplateRefs" $ do + it "should load templates from given references" $ do + let env' = + env + & (envFileSystemL . fsFindFilesByExtsL .~ fsFindFilesByExts') + & (envFileSystemL . fsLoadFileL .~ fsLoadFile') + & (envNetworkL . nDownloadContentL .~ nDownloadContent') + fsFindFilesByExts' = \path _ -> case path of + "test-dir" -> pure ["haskell.mustache", "rust.mustache"] + _ -> throwString "INVALID" + fsLoadFile' = \case + "haskell.mustache" -> pure "haskell local" + "rust.mustache" -> pure "rust local" + _ -> throwString "INVALID" + nDownloadContent' = \case + [uri|http://test.com/haskell.mustache|] -> pure "haskell URI" + _ -> throwString "INVALID" + refs = + [ UriTemplateRef [uri|http://test.com/haskell.mustache|] + , LocalTemplateRef "test-dir" + ] + templates <- runRIO env' $ loadTemplateRefs @Mustache refs + M.size templates `shouldBe` 2 + M.member Haskell templates `shouldBe` True + M.member Rust templates `shouldBe` True + rawTemplate <$> M.lookup Haskell templates `shouldBe` Just "haskell local" + rawTemplate <$> M.lookup Rust templates `shouldBe` Just "rust local" + + describe "typeOfTemplate" $ do let fileTypes = fmap (T.toLower . enumToText) (allValues @FileType) templateExt = NE.head $ templateExtensions @TemplateType @@ -134,6 +173,7 @@ env = TestEnv { .. } , fsListFiles = undefined , fsLoadFile = undefined } + envNetwork = Network { nDownloadContent = undefined } envHeaderFnConfigs = HeaderFnConfigs { hfcsUpdateCopyright = HeaderFnConfig { hfcEnabled = True diff --git a/test/Headroom/Template/TemplateRefSpec.hs b/test/Headroom/Template/TemplateRefSpec.hs index c6f0f3e..3034b30 100644 --- a/test/Headroom/Template/TemplateRefSpec.hs +++ b/test/Headroom/Template/TemplateRefSpec.hs @@ -10,6 +10,7 @@ module Headroom.Template.TemplateRefSpec where +import Headroom.Template.Mustache ( Mustache ) import Headroom.Template.TemplateRef import RIO import qualified RIO.List as L @@ -24,19 +25,37 @@ spec = do it "creates valid reference to local Haskell template" $ do let raw = "/path/to/some/haskell.mustache" expected = LocalTemplateRef "/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" expected = UriTemplateRef [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 + it "throws error if URI is valid but file type is not supported" $ do + let raw = "http://foo/bar.mustache" + mkTemplateRef @Mustache raw `shouldThrow` \case + (UnrecognizedTemplateName _) -> True + _ -> False + + + describe "renderRef" $ do + it "renders local template reference to human friendly text" $ do + let sample = LocalTemplateRef "/path/to/some/haskell.mustache" + expected = "/path/to/some/haskell.mustache" + renderRef sample `shouldBe` expected + + it "renders URI template reference to human friendly text" $ do + let sample = UriTemplateRef [uri|http://foo/haskell.mustache|] + expected = "http://foo/haskell.mustache" + renderRef sample `shouldBe` expected + describe "Ord instance for TemplateRef" $ do it "should properly order records" $ do