diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2017 Richard Cook +Copyright (c) 2017-2018 Richard Cook Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -96,7 +96,7 @@ ```bash cd _app/ -stack exec -- pansite-app --port 3000 +stack exec -- pansite --port 3000 ``` In your web browser, navigate to a route defined in `.pansite.yaml`, e.g. `http://localhost:3000/page2`. @@ -104,10 +104,10 @@ ## Command-line options ```terminal -$ stack exec -- pansite-app --help +$ stack exec -- pansite --help Pansite development server 0.1.0.0.772a2d5 (locally modified) -Usage: pansite-app ([-p|--port PORT] [-c|--config CONFIG] +Usage: pansite ([-p|--port PORT] [-c|--config CONFIG] [-o|--output-dir OUTPUTDIR] | [-v|--version]) Run Pansite development server @@ -124,7 +124,7 @@ Released under [MIT License][licence] -Copyright © 2017 Richard Cook +Copyright © 2017—2018 Richard Cook [app-example]: _app/.pansite.yaml [cmd-hackage]: https://hackage.haskell.org/package/shake-0.15.11/docs/Development-Shake-Command.html diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,7 +1,7 @@ {-| Module : Setup Description : Setup for Pansite -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,7 +1,7 @@ {-| Module : Main Description : Main entrypoint for Pansite app -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental diff --git a/app/PansiteApp/App.hs b/app/PansiteApp/App.hs --- a/app/PansiteApp/App.hs +++ b/app/PansiteApp/App.hs @@ -1,7 +1,7 @@ {-| Module : PansiteApp.App Description : Main entrypoint for Pansite application -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental diff --git a/app/PansiteApp/Build.hs b/app/PansiteApp/Build.hs --- a/app/PansiteApp/Build.hs +++ b/app/PansiteApp/Build.hs @@ -1,7 +1,7 @@ {-| Module : PansiteApp.Build Description : Shake build function -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental @@ -13,41 +13,32 @@ module PansiteApp.Build (build) where import Control.Monad -import Data.String.Utils import Development.Shake import Pansite import PansiteApp.ConfigInfo -import PansiteApp.Util --- TODO: Patterns must only contain zero or one "%" characters --- This should be enforced! -shakePattern :: FilePath -> FilePath -shakePattern = replace "%" "*" - --- TODO: Patterns must only contain zero or one "%" characters --- This should be enforced! -expandWildcardPattern :: String -> String -> FilePath -expandWildcardPattern = replace "%" - build :: ConfigInfo -> FilePath -> IO () build (ConfigInfo AppPaths{..} _ (App _ targets)) targetPath = shake shakeOptions { shakeFiles = apShakeDir } $ do liftIO $ putStrLn ("want: " ++ targetPath) want [targetPath] - forM_ targets $ \(Target path toolConfig inputPaths dependencyPaths) -> do - liftIO $ putStrLn ("rule: " ++ path) - shakePattern path %> \outputPath -> do - let (stem, "%") = stems outputPath path -- TODO: Is this kind of irrefutable pattern OK? It's an assert of sorts. - replaceWithStem = expandWildcardPattern stem - inputPaths' = map replaceWithStem inputPaths - dependencyPaths' = map replaceWithStem dependencyPaths + forM_ targets $ \(Target pathMakePattern tool inputPathPatterns dependencyPathPatterns) -> do + liftIO $ do + putStrLn $ "pathMakePattern: " ++ show pathMakePattern + putStrLn $ "inputPathPatterns: " ++ show inputPathPatterns + putStrLn $ "dependencyPathPatterns: " ++ show dependencyPathPatterns + pathMakePattern %%>> \outputPath -> do + let stem = pathPatternStem pathMakePattern outputPath + inputPaths = map (substituteStem stem) inputPathPatterns + dependencyPaths = map (substituteStem stem) dependencyPathPatterns + liftIO $ do - putStrLn ("need: " ++ show inputPaths') - putStrLn ("need: " ++ show dependencyPaths') - need inputPaths' - need dependencyPaths' + putStrLn $ "need: " ++ show inputPaths + putStrLn $ "need: " ++ show dependencyPaths + need inputPaths + need dependencyPaths - let ctx = ToolContext outputPath inputPaths' dependencyPaths' - liftIO $ toolConfigRunner ctx toolConfig + let ctx = RunContext outputPath inputPaths dependencyPaths + liftIO $ runTool ctx tool diff --git a/app/PansiteApp/CommandLine.hs b/app/PansiteApp/CommandLine.hs --- a/app/PansiteApp/CommandLine.hs +++ b/app/PansiteApp/CommandLine.hs @@ -1,7 +1,7 @@ {-| Module : PansiteApp.CommandLine Description : Command-line parsers for Pansite app -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental @@ -14,6 +14,7 @@ , parseCommand ) where +import Data.Monoid ((<>)) import Options.Applicative import PansiteApp.VersionInfo diff --git a/app/PansiteApp/ConfigInfo.hs b/app/PansiteApp/ConfigInfo.hs --- a/app/PansiteApp/ConfigInfo.hs +++ b/app/PansiteApp/ConfigInfo.hs @@ -1,7 +1,7 @@ {-| Module : PansiteApp.ConfigInfo Description : Configuration info for Pansite app -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental @@ -51,7 +51,7 @@ readConfigInfo :: AppPaths -> IO ConfigInfo readConfigInfo appPaths@AppPaths{..} = do - let ctx = ParserContext (resolveFilePath appPaths) + let ctx = UpdateContext (resolveFilePath appPaths) -- TODO: Use UTCTime field to determine if shakeVersion should be incremented currentTime <- getCurrentTime @@ -61,7 +61,7 @@ then do putStrLn $ "Getting timestamp for configuration file " ++ apAppYamlPath t <- getModificationTime apAppYamlPath - mbApp <- readApp ctx [copyToolSpec, pandocToolSpec] apAppYamlPath + mbApp <- readApp ctx [copyTool, pandocTool] apAppYamlPath case mbApp of Left message -> do putStrLn $ "Could not parse configuration file at " ++ apAppYamlPath ++ ": " ++ message diff --git a/app/PansiteApp/CopyTool.hs b/app/PansiteApp/CopyTool.hs --- a/app/PansiteApp/CopyTool.hs +++ b/app/PansiteApp/CopyTool.hs @@ -1,7 +1,7 @@ {-| Module : PansiteApp.CopyTool Description : Copy tool -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental @@ -10,24 +10,16 @@ {-# LANGUAGE OverloadedStrings #-} -module PansiteApp.CopyTool (copyToolSpec) where +module PansiteApp.CopyTool (copyTool) where import Data.Aeson -import Data.Aeson.Types -import Data.Default import Pansite data CopySettings = CopySettings -instance Default CopySettings where - def = CopySettings - -updater :: ParserContext -> CopySettings -> Value -> Parser CopySettings -updater _ orig = - withObject "copy" $ \_ -> pure orig - -runner :: ToolContext -> CopySettings -> IO () -runner _ _ = error "Not implemented" +copyTool :: Tool +copyTool = mkTool CopySettings -copyToolSpec :: ToolSpec -copyToolSpec = ToolSpec "copy" updater runner +mkTool :: CopySettings -> Tool +mkTool state = Tool "copy" updater (error "Not implemented") + where updater _ value = mkTool <$> (withObject "copy" $ const (pure state)) value diff --git a/app/PansiteApp/PandocTool.hs b/app/PansiteApp/PandocTool.hs --- a/app/PansiteApp/PandocTool.hs +++ b/app/PansiteApp/PandocTool.hs @@ -1,7 +1,7 @@ {-| Module : PansiteApp.PandocTool Description : Pandoc tool -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental @@ -11,27 +11,40 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module PansiteApp.PandocTool (pandocToolSpec) where +module PansiteApp.PandocTool (pandocTool) where import Data.Aeson import Data.Aeson.Types import qualified Data.ByteString.Lazy as BL import Data.Default import Data.List +import qualified Data.Text as Text (pack) +import qualified Data.Text.IO as Text (writeFile) import Pansite import PansiteApp.Util import System.FilePath import Text.Blaze.Html.Renderer.String import Text.Pandoc -import Text.Pandoc.Walk -import Text.Pandoc.XML + ( Extension(..) + , HTMLMathMethod(..) + , Inline(..) + , WriterOptions(..) + , enableExtension + , readMarkdown + , readerExtensions + , runPure + , writeDocx + , writeHtml5 + ) +import Text.Pandoc.Walk (walk) +import Text.Pandoc.XML (toEntities) data PandocSettings = PandocSettings { psNumberSections :: Bool , psVars :: [(String, String)] , psTemplatePath :: Maybe FilePath , psTableOfContents :: Bool - , psReferenceDocx :: Maybe FilePath + , psReferenceDoc :: Maybe FilePath , psMathJaxEnabled :: Bool , psIncludeInHeaderPath :: Maybe FilePath , psIncludeBeforeBodyPath :: Maybe FilePath @@ -41,8 +54,8 @@ instance Default PandocSettings where def = PandocSettings False [] Nothing False Nothing False Nothing Nothing Nothing -updater :: ParserContext -> PandocSettings -> Value -> Parser PandocSettings -updater (ParserContext resolveFilePath) PandocSettings{..} = +updater :: PandocSettings -> UpdateContext -> Value -> Parser PandocSettings +updater PandocSettings{..} (UpdateContext resolveFilePath) = withObject "pandoc" $ \o -> let getFilePath key d = fmap (resolveFilePath <$>) (o .:? key .!= d) in PandocSettings @@ -50,7 +63,7 @@ <*> o .:? "vars" .!= psVars <*> getFilePath "template-path" psTemplatePath <*> o .:? "table-of-contents" .!= psTableOfContents - <*> getFilePath "reference-docx" psReferenceDocx + <*> getFilePath "reference-doc" psReferenceDoc <*> o .:? "mathjax" .!= psMathJaxEnabled <*> getFilePath "include-in-header-path" psIncludeInHeaderPath <*> getFilePath "include-before-body-path" psIncludeBeforeBodyPath @@ -87,30 +100,37 @@ return $ def { writerNumberSections = psNumberSections - , writerReferenceDocx = psReferenceDocx + , writerReferenceDoc = psReferenceDoc , writerTemplate = mbTemplate , writerTableOfContents = psTableOfContents , writerHTMLMathMethod = htmlMathMethod , writerVariables = psVars3 } -runner :: ToolContext -> PandocSettings -> IO () +runner :: PandocSettings -> RunContext -> IO () runner - (ToolContext outputPath inputPaths _) - ps@PandocSettings{..} = do + ps@PandocSettings{..} + (RunContext outputPath inputPaths _) = do putStrLn "PandocTool" putStrLn $ " outputPath=" ++ outputPath putStrLn $ " inputPaths=" ++ show inputPaths putStrLn $ " psNumberSections=" ++ show psNumberSections - putStrLn $ " psReferenceDocx=" ++ show psReferenceDocx + putStrLn $ " psReferenceDoc=" ++ show psReferenceDoc putStrLn $ " psTableOfContents=" ++ show psTableOfContents putStrLn $ " psTemplatePath=" ++ show psTemplatePath putStrLn $ " psVars=" ++ show psVars md <- (intercalate "\n\n") <$> sequence (map readFileUtf8 inputPaths) - let Right doc' = readMarkdown def md -- TODO: Irrefutable pattern + let mdText = Text.pack md + readerOpts = def + exts = foldl' + (flip enableExtension) + (readerExtensions readerOpts) + [Ext_backtick_code_blocks, Ext_yaml_metadata_block] + readerOpts' = readerOpts { readerExtensions = exts } + Right doc' = runPure $ readMarkdown readerOpts' mdText -- TODO: Irrefutable pattern doc = walk rewriteLinks doc' writerOpts <- mkWriterOptions ps @@ -118,11 +138,12 @@ -- TODO: Ugh. Let's make this less hacky. It works for now though. case (takeExtension outputPath) of ".docx" -> do - docx <- writeDocx writerOpts doc + let Right docx = runPure $ writeDocx writerOpts doc -- TODO: Irrefutable pattern BL.writeFile outputPath docx _ -> do - let html = toEntities (renderHtml (writeHtml writerOpts doc)) - writeFileUtf8 outputPath html + let Right html = runPure $ writeHtml5 writerOpts doc -- TODO: Irrefutable pattern + t = toEntities (Text.pack $ renderHtml html) + Text.writeFile outputPath t -- TODO: This is very application-specific -- TODO: Figure out how to allow this behaviour to be specified in app configuration @@ -139,5 +160,9 @@ rewriteLinks (Link attr is (url, title)) = Link attr is (transformUrl url, title) rewriteLinks i = i -pandocToolSpec :: ToolSpec -pandocToolSpec = ToolSpec "pandoc" updater runner +pandocTool :: Tool +pandocTool = mkTool $ PandocSettings False [] Nothing False Nothing False Nothing Nothing Nothing + +mkTool :: PandocSettings -> Tool +mkTool state = Tool "pandoc" updater' (runner state) + where updater' ctx value = mkTool <$> updater state ctx value diff --git a/app/PansiteApp/Util.hs b/app/PansiteApp/Util.hs --- a/app/PansiteApp/Util.hs +++ b/app/PansiteApp/Util.hs @@ -1,7 +1,7 @@ {-| -Module : Pansite.Config.Types +Module : PansiteApp.Util Description : Helper functions for Pansite application -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental @@ -12,72 +12,11 @@ ( readFileUtf8 , readFileWithEncoding , skipDirectory - , stems - , writeFileUtf8 - , writeFileWithEncoding ) where import System.FilePath import System.IO - --- | Compute common prefix of two lists --- --- Examples: --- --- >>> commonPrefix "abcdefghi" "abcdefghi" --- "abcdefghi" --- >>> commonPrefix "abcdefghi" "abcfoo" --- "abc" --- >>> commonPrefix "abc" "xyz" --- "" -commonPrefix :: (Eq a) => [a] -> [a] -> [a] -commonPrefix _ [] = [] -commonPrefix [] _ = [] -commonPrefix (x : xs) (y : ys) - | x == y = x : commonPrefix xs ys - | otherwise = [] - --- | Compute common suffix of two lists --- --- Examples: --- --- >>> commonSuffix "abcdefghi" "abcdefghi" --- "abcdefghi" --- >>> commonSuffix "abcdefghi" "fooghi" --- "ghi" --- >>> commonSuffix "abc" "xyz" --- "" -commonSuffix :: (Eq a) => [a] -> [a] -> [a] -commonSuffix xs ys = reverse (commonPrefix (reverse xs) (reverse ys)) - --- | Slice of list --- --- Examples: --- --- >>> slice 4 10 "helloworldgoodbye" --- "oworld" -slice :: Int -> Int -> [a] -> [a] -slice p0 p1 xs = take (p1 - p0) (drop p0 xs) - --- | Stems of lists --- --- Examples: --- --- >>> stems "abcmiddledef" "abcfoodef" --- ("middle","foo") --- >>> stems "abc" "xyz" --- ("abc","xyz") -stems :: (Eq a) => [a] -> [a] -> ([a], [a]) -stems xs ys = - let prefix = commonPrefix xs ys - prefixCount = length prefix - suffix = commonSuffix xs ys - suffixCount = length suffix - xsCount = length xs - ysCount = length ys - in (slice prefixCount (xsCount - suffixCount) xs, slice prefixCount (ysCount - suffixCount) ys) - readFileWithEncoding :: TextEncoding -> FilePath -> IO String readFileWithEncoding encoding path = do h <- openFile path ReadMode @@ -86,15 +25,6 @@ readFileUtf8 :: FilePath -> IO String readFileUtf8 = readFileWithEncoding utf8 - -writeFileWithEncoding :: TextEncoding -> FilePath -> String -> IO () -writeFileWithEncoding encoding path content = - withFile path WriteMode $ \h -> do - hSetEncoding h encoding - hPutStr h content - -writeFileUtf8 :: FilePath -> String -> IO () -writeFileUtf8 = writeFileWithEncoding utf8 skipDirectory :: FilePath -> FilePath skipDirectory p = let d = takeDirectory p in drop (length d + 1) p diff --git a/app/PansiteApp/VersionInfo.hs b/app/PansiteApp/VersionInfo.hs --- a/app/PansiteApp/VersionInfo.hs +++ b/app/PansiteApp/VersionInfo.hs @@ -1,7 +1,7 @@ {-| Module : Pansite.VersionInfo Description : Version information for Pansite application -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental diff --git a/doctest/Main.hs b/doctest/Main.hs --- a/doctest/Main.hs +++ b/doctest/Main.hs @@ -1,23 +1,38 @@ {-| Module : Main Description : Main entrypoint for Pansite doctests -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental Portability : portable -} +{-# LANGUAGE CPP #-} + module Main (main) where import System.FilePath.Glob import Test.DocTest +compilerOpts :: [String] +compilerOpts = +#if defined(OS_LINUX) + [ "-DOS_LINUX" +#elif defined(OS_MACOS) + [ "-DOS_MACOS" +#elif defined(OS_WINDOWS) + [ "-DOS_WINDOWS" +#else +#error Unsupported platform +#endif + ] + defaultIncludeDirs :: [FilePath] defaultIncludeDirs = [] doctestWithIncludeDirs :: [FilePath] -> IO () -doctestWithIncludeDirs fs = doctest (map ("-I" ++) defaultIncludeDirs ++ fs) +doctestWithIncludeDirs fs = doctest (map ("-I" ++) defaultIncludeDirs ++ fs ++ compilerOpts) sourceDirs :: [FilePath] sourceDirs = ["app", "src"] diff --git a/pansite.cabal b/pansite.cabal --- a/pansite.cabal +++ b/pansite.cabal @@ -1,13 +1,13 @@ name: pansite -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Pansite: a simple web site management tool -description: Please see README.md +description: Pansite is a Pandoc-based web site management tool. Please see README.md homepage: https://github.com/rcook/pansite#readme license: MIT license-file: LICENSE author: Richard Cook maintainer: rcook@rcook.org -copyright: 2017 Richard Cook +copyright: 2017-2018 Richard Cook category: Web build-type: Simple extra-source-files: README.md @@ -20,24 +20,41 @@ library default-language: Haskell2010 ghc-options: -W -Wall -fwarn-incomplete-patterns -fwarn-unused-imports + if os(darwin) + cpp-options: -DOS_MACOS + if os(linux) + cpp-options: -DOS_LINUX + if os(windows) + cpp-options: -DOS_WINDOWS hs-source-dirs: src exposed-modules: Pansite other-modules: Pansite.Config , Pansite.Config.Funcs , Pansite.Config.Types - build-depends: aeson + , Pansite.Config.Util + , Pansite.PathPattern + , Pansite.Util + build-depends: MissingH + , aeson , base >= 4.7 && < 5 , bytestring , data-default + , shake , split , text , unordered-containers , vector , yaml -executable pansite-app +executable pansite default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N -W -Wall -fwarn-incomplete-patterns -fwarn-unused-imports + if os(darwin) + cpp-options: -DOS_MACOS + if os(linux) + cpp-options: -DOS_LINUX + if os(windows) + cpp-options: -DOS_WINDOWS hs-source-dirs: app main-is: Main.hs other-modules: PansiteApp.App @@ -48,6 +65,7 @@ , PansiteApp.PandocTool , PansiteApp.Util , PansiteApp.VersionInfo + , Paths_pansite build-depends: MissingH , aeson , base >= 4.7 && < 5 @@ -62,6 +80,7 @@ , pandoc-types , pansite , shake + , split , template-haskell , text , time @@ -75,6 +94,12 @@ type: exitcode-stdio-1.0 default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N -W -Wall -fwarn-incomplete-patterns -fwarn-unused-imports + if os(darwin) + cpp-options: -DOS_MACOS + if os(linux) + cpp-options: -DOS_LINUX + if os(windows) + cpp-options: -DOS_WINDOWS hs-source-dirs: doctest main-is: Main.hs build-depends: Glob @@ -85,8 +110,16 @@ type: exitcode-stdio-1.0 default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N -W -Wall -fwarn-incomplete-patterns -fwarn-unused-imports + if os(darwin) + cpp-options: -DOS_MACOS + if os(linux) + cpp-options: -DOS_LINUX + if os(windows) + cpp-options: -DOS_WINDOWS hs-source-dirs: spec main-is: Spec.hs - build-depends: base >= 4.7 && < 5 + other-modules: PansiteSpec.Config.UtilSpec + build-depends: QuickCheck + , base >= 4.7 && < 5 , hspec , pansite diff --git a/spec/PansiteSpec/Config/UtilSpec.hs b/spec/PansiteSpec/Config/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/spec/PansiteSpec/Config/UtilSpec.hs @@ -0,0 +1,17 @@ +module PansiteSpec.Config.UtilSpec (spec) where + +import Data.List +import Pansite +import Test.Hspec +import Test.QuickCheck + +genRoutePath :: Gen String +genRoutePath = intercalate "/" <$> listOf (listOf $ elements ['a'..'z']) + +unsplitRoutePathProp :: Property +unsplitRoutePathProp = forAll genRoutePath $ \p -> intercalate "/" (splitRoutePath p) == p + +spec :: Spec +spec = do + describe "splitRoutePath" $ + it "satisfies unsplitRoutePathProp" $ property unsplitRoutePathProp diff --git a/spec/Spec.hs b/spec/Spec.hs --- a/spec/Spec.hs +++ b/spec/Spec.hs @@ -1,7 +1,7 @@ {-| Module : Main Description : Main entrypoint for Pansite spec tests -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental diff --git a/src/Pansite.hs b/src/Pansite.hs --- a/src/Pansite.hs +++ b/src/Pansite.hs @@ -1,7 +1,7 @@ {-| Module : Pansite Description : Umbrella module for Pansite -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental @@ -10,6 +10,10 @@ module Pansite ( module Pansite.Config + , module Pansite.PathPattern + , module Pansite.Util ) where import Pansite.Config +import Pansite.PathPattern +import Pansite.Util diff --git a/src/Pansite/Config.hs b/src/Pansite/Config.hs --- a/src/Pansite/Config.hs +++ b/src/Pansite/Config.hs @@ -1,7 +1,7 @@ {-| Module : Pansite.Config Description : Umbrella module for Pansite app configuration -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental @@ -11,7 +11,9 @@ module Pansite.Config ( module Pansite.Config.Funcs , module Pansite.Config.Types + , module Pansite.Config.Util ) where import Pansite.Config.Funcs import Pansite.Config.Types +import Pansite.Config.Util diff --git a/src/Pansite/Config/Funcs.hs b/src/Pansite/Config/Funcs.hs --- a/src/Pansite/Config/Funcs.hs +++ b/src/Pansite/Config/Funcs.hs @@ -1,7 +1,7 @@ {-| Module : Pansite.Config.Types Description : Functions for Pansite app configuration -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental @@ -13,86 +13,83 @@ module Pansite.Config.Funcs ( readApp - , toolConfigRunner + , runTool ) where import Control.Monad import Data.Aeson.Types import qualified Data.ByteString.Char8 as C8 -import Data.Default import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.List.Split import Data.Text (Text) import qualified Data.Text as Text import Data.Traversable import qualified Data.Vector as Vector import Data.Yaml import Pansite.Config.Types +import Pansite.Config.Util +import Pansite.PathPattern -type ToolConfigMap = HashMap String ToolConfig +type ToolMap = HashMap String Tool -defaultToolConfig :: ToolSpec -> ToolConfig -defaultToolConfig (ToolSpec _ u r) = ToolConfig u r def +updateTool :: UpdateContext -> Tool -> Value -> Parser Tool +updateTool ctx (Tool _ u _) value = u ctx value -toolConfigUpdater :: ParserContext -> ToolConfig -> Value -> Parser ToolConfig -toolConfigUpdater ctx (ToolConfig u r a) value = do - result <- u ctx a value - return $ ToolConfig u r result +updateTools :: UpdateContext -> ToolMap -> [(String, Value)] -> Parser ToolMap +updateTools ctx = foldM (\m (key, value) -> case HashMap.lookup key m of + Nothing -> fail $ "Unsupported tool " ++ key + Just toolConfigOrig -> do + toolConfig <- updateTool ctx toolConfigOrig value + return $ HashMap.insert key toolConfig m) -toolConfigRunner :: ToolContext -> ToolConfig -> IO () -toolConfigRunner ctx (ToolConfig _ r a) = r ctx a +runTool :: RunContext -> Tool -> IO () +runTool ctx (Tool _ _ r) = r ctx arrayParser :: Object -> Text -> (Value -> Parser a) -> Parser [a] -arrayParser o key parser = helper (Text.unpack key) parser =<< (o .: key) +arrayParser o key parser = helper (Text.unpack key) parser =<< o .: key where helper expected f = withArray expected $ \arr -> mapM f (Vector.toList arr) --- TODO: Create a unit test for this! -parseRoutePath :: String -> [String] -parseRoutePath path = - let fragments = splitOn "/" path - fragmentCount = length fragments - in if (fragmentCount == 1 && fragments !! 0 == "") - then [] - else fragments - -appParser :: ParserContext -> [ToolSpec] -> Value -> Parser App -appParser ctx toolSpecs = withObject "App" $ \o -> do - let toolConfigMapOrig = HashMap.fromList (map (\t@(ToolSpec k _ _) -> (k, defaultToolConfig t)) toolSpecs) - toolConfigPairs <- toolConfigsParser =<< o .:? "tool-settings" .!= emptyObject - toolConfigMap <- updateToolConfigs ctx toolConfigMapOrig toolConfigPairs +appParser :: UpdateContext -> [Tool] -> Value -> Parser App +appParser ctx tools = withObject "App" $ \o -> do + let toolMapOrig = HashMap.fromList (map (\t@(Tool k _ _) -> (k, t)) tools) + toolSettings <- toolSettingsParser =<< o .:? "tool-settings" .!= emptyObject + toolMapNew <- updateTools ctx toolMapOrig toolSettings routes <- arrayParser o "routes" (routeParser ctx) - targets <- arrayParser o "targets" (targetParser ctx toolConfigMap) + targets <- arrayParser o "targets" (targetParser ctx toolMapNew) return $ App routes targets -toolConfigsParser :: Value -> Parser [(String, Value)] -toolConfigsParser = withObject "tool-settings" $ \o -> +toolSettingsParser :: Value -> Parser [(String, Value)] +toolSettingsParser = withObject "tool-settings" $ \o -> for (HashMap.toList o) $ \(name, value) -> return (Text.unpack name, value) -updateToolConfigs :: ParserContext -> ToolConfigMap -> [(String, Value)] -> Parser ToolConfigMap -updateToolConfigs ctx = foldM (\m (key, value) -> case HashMap.lookup key m of - Nothing -> fail $ "Unsupported tool " ++ key - Just toolConfigOrig -> do - toolConfig <- toolConfigUpdater ctx toolConfigOrig value - return $ HashMap.insert key toolConfig m) - -routeParser :: ParserContext -> Value -> Parser Route -routeParser (ParserContext resolveFilePath) = +routeParser :: UpdateContext -> Value -> Parser Route +routeParser (UpdateContext resolveFilePath) = withObject "route" $ \o -> Route - <$> parseRoutePath <$> o .: "path" + <$> splitRoutePath <$> o .: "path" <*> (resolveFilePath <$> o .: "target") -targetParser :: ParserContext -> ToolConfigMap -> Value -> Parser Target -targetParser ctx@(ParserContext resolveFilePath) toolConfigMap = +pathPatternParser :: FilePathResolver -> String -> Parser PathPattern +pathPatternParser resolveFilePath s = case pathPattern (resolveFilePath s) of + Left message -> fail message + Right p -> return p + +targetParser :: UpdateContext -> ToolMap -> Value -> Parser Target +targetParser ctx@(UpdateContext resolveFilePath) toolMap = withObject "target" $ \o -> do - path <- resolveFilePath <$> o .: "path" + let pathPatternParser' = pathPatternParser resolveFilePath + + path <- pathPatternParser' =<< o .: "path" + key <- o .: "tool" - toolConfigOrig <- case HashMap.lookup key toolConfigMap of + toolConfigOrig <- case HashMap.lookup key toolMap of Nothing -> fail $ "Unsupported tool " ++ key Just p -> return p - toolConfig <- toolConfigUpdater ctx toolConfigOrig =<< o .:? "tool-settings" .!= emptyObject - inputPaths <- ((map resolveFilePath) <$> o .: "inputs") - dependencyPaths <- ((map resolveFilePath) <$> o .: "dependencies") + toolConfig <- updateTool ctx toolConfigOrig =<< o .:? "tool-settings" .!= emptyObject + + inputPaths <- mapM pathPatternParser' =<< o .: "inputs" + + dependencyPaths <- mapM pathPatternParser' =<< o .: "dependencies" + return $ Target path toolConfig inputPaths dependencyPaths parseExceptionMessage :: FilePath -> ParseException -> String @@ -110,15 +107,15 @@ "Invalid configuration: " ++ problem ++ "\n" ++ "Location: " ++ appYamlPath -readApp :: ParserContext -> [ToolSpec] -> FilePath -> IO (Either String App) -readApp ctx toolSpecs appYamlPath = do +readApp :: UpdateContext -> [Tool] -> FilePath -> IO (Either String App) +readApp ctx tools appYamlPath = do yaml <- C8.readFile appYamlPath case decodeEither' yaml of Left e -> do putStrLn $ "WARNING: " ++ parseExceptionMessage appYamlPath e return $ Left (show e) Right value -> do - case parse (appParser ctx toolSpecs) value of + case parse (appParser ctx tools) value of Error problem -> do putStrLn $ "WARNING: " ++ resultErrorMessage appYamlPath problem return $ Left problem @@ -126,5 +123,5 @@ forM_ routes $ \(Route path target) -> putStrLn $ "Route: " ++ show path ++ " -> " ++ target forM_ targets $ \(Target path _ inputPaths dependencyPaths) -> do - putStrLn $ "Target: " ++ path ++ ", " ++ show inputPaths ++ ", " ++ show dependencyPaths + putStrLn $ "Target: " ++ show path ++ ", " ++ show inputPaths ++ ", " ++ show dependencyPaths return $ Right app diff --git a/src/Pansite/Config/Types.hs b/src/Pansite/Config/Types.hs --- a/src/Pansite/Config/Types.hs +++ b/src/Pansite/Config/Types.hs @@ -1,54 +1,43 @@ {-| Module : Pansite.Config.Types Description : Types for Pansite app configuration -Copyright : (C) Richard Cook, 2017 +Copyright : (C) Richard Cook, 2017-2018 Licence : MIT Maintainer : rcook@rcook.org Stability : experimental Portability : portable -} -{-# LANGUAGE ExistentialQuantification #-} - module Pansite.Config.Types ( App (..) , FilePathResolver - , ParserContext (..) , Route (..) + , RunContext (..) , Target (..) - , ToolConfig (..) - , ToolConfigRunner - , ToolConfigUpdater - , ToolContext (..) - , ToolSpec (..) + , Tool (..) + , UpdateContext (..) ) where -import Data.Default import Data.Yaml +import Pansite.PathPattern type FilePathResolver = FilePath -> FilePath -type ToolConfigUpdater a = ParserContext -> a -> Value -> Parser a - -type ToolConfigRunner a = ToolContext -> a -> IO () - -data ParserContext = ParserContext +data UpdateContext = UpdateContext FilePathResolver -- file path resolver -data ToolContext = ToolContext +data RunContext = RunContext FilePath -- output path [FilePath] -- input paths [FilePath] -- dependency paths -data ToolSpec = forall a. Default a => ToolSpec - String -- key - (ToolConfigUpdater a) -- updater function - (ToolConfigRunner a) -- runner function +data Tool = Tool + String -- key + (UpdateContext -> Value -> Parser Tool) -- update function + (RunContext -> IO ()) -- run function data App = App [Route] [Target] data Route = Route [String] FilePath -data Target = Target FilePath ToolConfig [FilePath] [FilePath] - -data ToolConfig = forall a. ToolConfig (ToolConfigUpdater a) (ToolConfigRunner a) a +data Target = Target PathPattern Tool [PathPattern] [PathPattern] diff --git a/src/Pansite/Config/Util.hs b/src/Pansite/Config/Util.hs new file mode 100644 --- /dev/null +++ b/src/Pansite/Config/Util.hs @@ -0,0 +1,30 @@ +{-| +Module : Pansite.Config.Util +Description : Helper functions for Pansite app configuration +Copyright : (C) Richard Cook, 2017-2018 +Licence : MIT +Maintainer : rcook@rcook.org +Stability : experimental +Portability : portable +-} + +module Pansite.Config.Util + ( splitRoutePath + ) where + +import Data.List.Split + +-- | Split route path into fragments +-- +-- Examples: +-- +-- >>> splitRoutePath "aaa/bbb" +-- ["aaa","bbb"] +-- >>> splitRoutePath "aaa" +-- ["aaa"] +-- >>> splitRoutePath "" +-- [] +splitRoutePath :: String -> [String] +splitRoutePath path = case splitOn "/" path of + [""] -> [] + fragments -> fragments diff --git a/src/Pansite/PathPattern.hs b/src/Pansite/PathPattern.hs new file mode 100644 --- /dev/null +++ b/src/Pansite/PathPattern.hs @@ -0,0 +1,90 @@ +{-| +Module : Pansite.PathPattern +Description : GNU Make-style path patterns +Copyright : (C) Richard Cook, 2017-2018 +Licence : MIT +Maintainer : rcook@rcook.org +Stability : experimental +Portability : portable +-} + +{-# LANGUAGE CPP #-} + +module Pansite.PathPattern + ( PathPattern + , pathPattern + , pathPatternStem + , substituteStem + , (%%>>) + ) where + +import Data.String.Utils +import Development.Shake +import Development.Shake.FilePath +import Pansite.Util + +newtype PathPattern = PathPattern String deriving Show + +makeToken :: String +makeToken = "%" + +shakeToken :: String +shakeToken = "*" + +-- | Convert string to path pattern +-- +-- Examples: +-- +-- >>> import Data.Either +-- >>> isRight $ pathPattern "%" +-- True +-- >>> isRight $ pathPattern "aaa" +-- True +-- >>> isLeft $ pathPattern "%%" +-- True +-- >>> isLeft $ pathPattern "%aaa%" +-- True +pathPattern :: String -> Either String PathPattern +pathPattern s + | let n = countOccurrences s makeToken in n == 0 || n == 1 = Right $ PathPattern s + | otherwise = Left $ "Invalid path pattern " ++ s + +-- | Substitute stem in path pattern +-- +-- Examples: +-- +-- >>> Right p = pathPattern "/aaa/bbb/%/ddd/eee/" +-- >>> substituteStem "ccc" p +-- "/aaa/bbb/ccc/ddd/eee/" +substituteStem :: String -> PathPattern -> FilePath +substituteStem stem (PathPattern s) = replace makeToken stem s + +(%%>>) :: PathPattern -> (FilePath -> Action ()) -> Rules () +(%%>>) (PathPattern s) b = replace makeToken shakeToken s %> b +infix 1 %%>> + +#if defined(OS_MACOS) || defined(OS_LINUX) +-- | Stem of pattern and path +-- +-- Examples: +-- +-- >>> Right p = pathPattern "C:/aaa/bbb/%.txt" +-- >>> pathPatternStem p "C:/aaa/bbb/stem.txt" +-- "stem" +#elif defined(OS_WINDOWS) +-- TODO: Enforce the wildcard token via the types! +-- | Find stem of path and rule +-- +-- Examples: +-- +-- >>> Right p0 = pathPattern "C:/aaa/bbb/%.txt" +-- >>> pathPatternStem p0 "C:\\aaa\\bbb\\stem.txt" +-- "stem" +-- >>> Right p1 = pathPattern "C:\\aaa\\bbb\\%.txt" +-- >>> pathPatternStem p1 "C:/aaa/bbb/stem.txt" +-- "stem" +#else +#error Unsupported platform +#endif +pathPatternStem :: PathPattern -> FilePath -> String +pathPatternStem (PathPattern s) path = let (stem, _) = stems (toNative path) (toNative s) in stem diff --git a/src/Pansite/Util.hs b/src/Pansite/Util.hs new file mode 100644 --- /dev/null +++ b/src/Pansite/Util.hs @@ -0,0 +1,92 @@ +{-| +Module : Pansite.Util +Description : Helper functions for Pansite +Copyright : (C) Richard Cook, 2017-2018 +Licence : MIT +Maintainer : rcook@rcook.org +Stability : experimental +Portability : portable +-} + +module Pansite.Util + ( countOccurrences + , stems + ) where + +import Data.List.Split + +-- | Number of occurrences of a substring in a string +-- +-- Examples: +-- +-- >>> countOccurrences "" "abc" +-- 0 +-- >>> countOccurrences "" "" +-- 0 +-- >>> countOccurrences "abcdefghi" "xyz" +-- 0 +-- >>> countOccurrences "abc" "abc" +-- 1 +-- >>> countOccurrences "abcabc" "abc" +-- 2 +-- >>> countOccurrences "abcdefabcghiabcjkl" "abc" +-- 3 +countOccurrences :: String -> String -> Int +countOccurrences str substr = length (splitOn substr str) - 1 + +-- | Compute common prefix of two lists +-- +-- Examples: +-- +-- >>> commonPrefix "abcdefghi" "abcdefghi" +-- "abcdefghi" +-- >>> commonPrefix "abcdefghi" "abcfoo" +-- "abc" +-- >>> commonPrefix "abc" "xyz" +-- "" +commonPrefix :: (Eq a) => [a] -> [a] -> [a] +commonPrefix _ [] = [] +commonPrefix [] _ = [] +commonPrefix (x : xs) (y : ys) + | x == y = x : commonPrefix xs ys + | otherwise = [] + +-- | Compute common suffix of two lists +-- +-- Examples: +-- +-- >>> commonSuffix "abcdefghi" "abcdefghi" +-- "abcdefghi" +-- >>> commonSuffix "abcdefghi" "fooghi" +-- "ghi" +-- >>> commonSuffix "abc" "xyz" +-- "" +commonSuffix :: (Eq a) => [a] -> [a] -> [a] +commonSuffix xs ys = reverse (commonPrefix (reverse xs) (reverse ys)) + +-- | Stems of lists +-- +-- Examples: +-- +-- >>> stems "abcmiddledef" "abcfoodef" +-- ("middle","foo") +-- >>> stems "abc" "xyz" +-- ("abc","xyz") +stems :: (Eq a) => [a] -> [a] -> ([a], [a]) +stems xs ys = + let prefix = commonPrefix xs ys + prefixCount = length prefix + suffix = commonSuffix xs ys + suffixCount = length suffix + xsCount = length xs + ysCount = length ys + in (slice prefixCount (xsCount - suffixCount) xs, slice prefixCount (ysCount - suffixCount) ys) + +-- | Slice of list +-- +-- Examples: +-- +-- >>> slice 4 10 "helloworldgoodbye" +-- "oworld" +slice :: Int -> Int -> [a] -> [a] +slice p0 p1 xs = take (p1 - p0) (drop p0 xs)