pansite 0.1.0.0 → 0.2.0.0

raw patch · 23 files changed

+439/−231 lines, 23 filesdep +QuickChecksetup-changednew-component:exe:pansitePVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• README.md +4/−4
• Setup.hs +1/−1
• app/Main.hs +1/−1
• app/PansiteApp/App.hs +1/−1
• app/PansiteApp/Build.hs +17/−26
• app/PansiteApp/CommandLine.hs +2/−1
• app/PansiteApp/ConfigInfo.hs +3/−3
• app/PansiteApp/CopyTool.hs +7/−15
• app/PansiteApp/PandocTool.hs +44/−19
• app/PansiteApp/Util.hs +2/−72
• app/PansiteApp/VersionInfo.hs +1/−1
• doctest/Main.hs +17/−2
• pansite.cabal +39/−6
• spec/PansiteSpec/Config/UtilSpec.hs +17/−0
• spec/Spec.hs +1/−1
• src/Pansite.hs +5/−1
• src/Pansite/Config.hs +3/−1
• src/Pansite/Config/Funcs.hs +49/−52
• src/Pansite/Config/Types.hs +12/−23
• src/Pansite/Config/Util.hs +30/−0
• src/Pansite/PathPattern.hs +90/−0
• src/Pansite/Util.hs +92/−0

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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"]

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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]

@@ -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

@@ -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

@@ -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)