+{-# LANGUAGE DeriveFunctor #-}
+
+module Webc.Compiler where
+
+import Control.Applicative (Applicative (..))
+import Control.Monad (Monad (..), forM_, when)
+import Data.Bool
+import Data.ByteString.Lazy qualified as BSL
+import Data.Either (Either (..))
+import Data.Eq (Eq (..))
+import Data.Foldable (null, toList)
+import Data.Function (($), (.))
+import Data.Functor (Functor (..), (<$>))
+import Data.Maybe (Maybe (..))
+import Data.Ord (Ord (..))
+import Data.Semigroup (Semigroup (..))
+import Data.Text qualified as Text
+import GHC.Base (error)
+import GHC.Stack (HasCallStack)
+import Network.URI.Slug (Slug)
+import Network.URI.Slug qualified as URI
+import Symantic (
+ Optionable (..),
+ ProductFunctor (..),
+ SumFunctor (..),
+ )
+import Symantic.Classes (Iso (..), IsoFunctor (..))
+import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist {-, getCurrentDirectory-})
+import System.FilePath (FilePath, takeDirectory, (</>))
+import System.FilePath qualified as FilePath
+import System.FilePattern.Directory (getDirectoryFiles)
+import System.IO (IO, hPutStrLn, stderr)
+import Text.Show (Show (..))
+import Webc.Classes hiding ((</>))
+import Webc.MIME (PlainText)
+
+-- * The 'Compiler' interpreter
+
+newtype Compiler a = Compiler
+ { unCompiler :: [Comp a]
+ }
+ deriving (Functor, Show)
+
+instance Applicative Compiler where
+ pure = Compiler . pure . pure
+ Compiler f <*> Compiler x = Compiler $ (<*>) <$> f <*> x
+
+-- instance Monad Compiler where
+-- return = pure
+-- Compiler x >>= f = Compiler (x >>=)
+
+data CompilerConf = CompilerConf
+ { compilerConfSource :: FilePath
+ , compilerConfDest :: FilePath
+ }
+
+compile :: Show a => Renderable a => Compiler a -> CompilerConf -> IO ()
+compile comp CompilerConf{..} = do
+ createDirectoryIfMissing True compilerConfDest
+ let routes = unCompiler comp
+ when (null routes) $
+ error "no routes, nothing to compile"
+ forM_ routes $ \c@Comp{..} -> do
+ hPutStrLn stderr $ "route: " <> show c
+ let routePath = pathOfSlugs compSlugs
+ in case render c of
+ Left staticPath ->
+ doesPathExist (compilerConfSource </> staticPath) >>= \case
+ True -> do
+ -- TODO: In current branch, we don't expect this to be a directory.
+ -- Although the user may pass it, but review before merge.
+ hPutStrLn stderr $
+ "staticCopy: "
+ <> show
+ ( (compilerConfSource </> staticPath)
+ , (compilerConfDest </> staticPath)
+ )
+ copyDirRecursively
+ routePath
+ (compilerConfSource </> staticPath)
+ (compilerConfDest </> staticPath)
+ False ->
+ return ()
+ -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
+ Right (bs, ext) -> do
+ hPutStrLn stderr $ "mkdir: " <> show (takeDirectory (compilerConfDest </> routePath))
+ createDirectoryIfMissing True (takeDirectory (compilerConfDest </> routePath))
+ hPutStrLn stderr $ "write: " <> show (compilerConfDest </> routePath FilePath.<.> ext)
+ BSL.writeFile (compilerConfDest </> routePath FilePath.<.> ext) bs
+
+-- ** Class 'Renderable'
+class Renderable a where
+ render :: Comp a -> Either FilePath (BSL.ByteString, FilePath)
+instance Renderable () where
+ render Comp{..} = Left $ pathOfSlugs compSlugs
+
+pathOfSlugs :: [Slug] -> FilePath
+pathOfSlugs s = Text.unpack $ Text.intercalate "/" $ URI.encodeSlug <$> s
+
+-- ** Type 'Comp'
+data Comp a = Comp
+ { compSlugs :: [Slug] -- TODO: Endo? Seq?
+ , compValue :: a
+ , compExt :: Maybe FilePath
+ }
+ deriving (Eq, Ord, Show, Functor)
+instance Applicative Comp where
+ pure compValue =
+ Comp
+ { compSlugs = []
+ , compValue
+ , compExt = Nothing
+ }
+ f <*> x =
+ Comp
+ { compSlugs = compSlugs f <> compSlugs x
+ , compValue = compValue f (compValue x)
+ , compExt = compExt f <> compExt x
+ }
+
+instance IsoFunctor Compiler where
+ (<%>) Iso{..} = (a2b <$>)
+instance ProductFunctor Compiler where
+ (<.>) = liftA2 (,)
+ (<.) = (<*)
+ (.>) = (*>)
+instance SumFunctor Compiler where
+ x <+> y =
+ Compiler $
+ (<>)
+ ((Left <$>) <$> unCompiler x)
+ ((Right <$>) <$> unCompiler y)
+instance Optionable Compiler where
+ optional x =
+ Compiler $
+ Comp{compSlugs = [], compValue = Nothing, compExt = Nothing} :
+ ((Just <$>) <$> unCompiler x)
+instance Slugable Compiler where
+ literalSlug s = Compiler [Comp{compSlugs = [s], compValue = (), compExt = Nothing}]
+ chooseSlug ss =
+ Compiler $
+ [ Comp{compSlugs = [s], compValue = s, compExt = Nothing}
+ | s <- toList ss
+ ]
+instance ContentTypeable PlainText () Compiler where
+ contentType =
+ Compiler
+ [ Comp
+ { compSlugs = []
+ , compValue = ()
+ , compExt = Just "txt"
+ }
+ ]
+
+-- instance Repeatable Compiler where
+-- many0 (Compiler x) =
+-- Compiler $
+-- ((\Comp{} -> Comp [] []) <$> x)
+-- <> ((\(Comp s a) -> Comp s [a]) <$> x)
+-- <> ((\(Comp s a) -> Comp (s <> s) [a, a]) <$> x)
+-- many1 (Compiler x) =
+-- Compiler $
+-- ((\(Comp s a) -> Comp s [a]) <$> x)
+-- <> ((\(Comp s a) -> Comp (s <> s) [a, a]) <$> x)
+-- instance Endable Compiler where
+-- end = Compiler [Comp [] ()]
+-- instance Capturable Compiler where
+-- captureSlug n = Compiler $ [Comp [n] n]
+-- instance Constantable c Compiler where
+-- constant = pure
+
+{-
+let (staticPaths, generatedPaths) =
+ lefts &&& rights $
+ routes <&> \r ->
+ case render model r of
+ AssetStatic fp -> Left (r, fp)
+ AssetComperated _fmt s -> Right (encodeRoute model r, s)
+paths <- forM generatedPaths $ \(relPath, !s) -> do
+ let fp = dest </> relPath
+ log LevelInfo $ toText $ "W " <> fp
+ liftIO $ do
+ createDirectoryIfMissing True (takeDirectory fp)
+ writeFileLBS fp s
+ pure fp
+forM_ staticPaths $ \(r, staticPath) -> do
+ liftIO (doesPathExist staticPath) >>= \case
+ True ->
+ -- TODO: In current branch, we don't expect this to be a directory.
+ -- Although the user may pass it, but review before merge.
+ copyDirRecursively (encodeRoute model r) staticPath dest
+ False ->
+ log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
+-}
+{-
+instance Slugable Compiler where
+ literalSlug s = Compiler $ return $ Endo (s :)
+ captureSlug _n = Compiler $ MT.ReaderT $ \s -> return $ Endo (s :)
+instance ProductFunctor Compiler where
+ Compiler x <.> Compiler y = Compiler $
+ MT.ReaderT $ \env ->
+ MT.withReaderT (\env -> env{compilerArgs = b2a (compilerArgs env)})
+ return $
+ MT.runReaderT x a
+ <> MT.runReaderT y b
+-}
+
+--deriving stock (Eq, Show, Ord, Comperic)
+
+{-
+
+safeForLarge' :: Int -> IO ()
+safeForLarge' n = flip finally (cleanup tmpfile) $ do
+ cleanup tmpfile
+ lgrset <- newFileLoggerSet defaultBufSize tmpfile
+ let xs = toLogStr $ BS.pack $ take (abs n) (cycle ['a'..'z'])
+ lf = "x"
+ pushLogStr lgrset $ xs <> lf
+ flushLogStr lgrset
+ rmLoggerSet lgrset
+ bs <- BS.readFile tmpfile
+ bs `shouldBe` BS.pack (take (abs n) (cycle ['a'..'z']) <> "x")
+ where
+ tmpfile = "test/temp"
+
+cleanup :: FilePath -> IO ()
+cleanup file = do
+ exist <- doesFileExist file
+ when exist $ removeFile file
+
+logAllMsgs :: IO ()
+logAllMsgs = logAll "LICENSE" `finally` cleanup tmpfile
+ where
+ tmpfile = "test/temp"
+ logAll file = do
+ cleanup tmpfile
+ lgrset <- newFileLoggerSet 512 tmpfile
+ src <- BS.readFile file
+ let bs = (<> "\n") . toLogStr <$> BS.lines src
+ mapM_ (pushLogStr lgrset) bs
+ flushLogStr lgrset
+ rmLoggerSet lgrset
+ dst <- BS.readFile tmpfile
+ dst `shouldBe` src
+
+compile ::
+ forall model m route.
+ ( -- MonadIO m,
+ -- MonadUnliftIO m,
+ -- MonadLoggerIO m,
+ -- Show r,
+ HasCallStack
+ ) =>
+ FilePath ->
+ model ->
+ (model -> route -> Asset BSL.ByteString) ->
+ -- | List of generated files.
+ IO ()
+compile dest model render = do
+ dirExists <- doesDirectoryExist dest
+ when (not dirExists) $ do
+ error $ "Destination does not exist: " <> dest
+ let routes = allRoutes model
+ when (null routes) $
+ error "allRoutes is empty; nothing to compile"
+ -- log LevelInfo $ "Writing " <> show (length routes) <> " routes"
+ let staticPaths =
+ (<$> routes) $ \route ->
+ case render model route of
+ AssetStatic fp -> Left (route, fp)
+ AssetComperated _fmt s -> Right (encodeRoute model route, s)
+ forM_ staticPaths $ \(route, staticPath) -> do
+ (doesPathExist staticPath) >>= \case
+ True ->
+ -- TODO: In current branch, we don't expect this to be a directory.
+ -- Although the user may pass it, but review before merge.
+ copyDirRecursively (encodeRoute model route) staticPath dest
+ False ->
+ return ()
+ -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
+
+log :: MonadLogger m => LogLevel -> Text -> m ()
+log = logWithoutLoc "Comperate"
+
+-- | Disable birdbrained hacks from GitHub to disable surprises like,
+-- https://github.com/jekyll/jekyll/issues/55
+noBirdbrainedJekyll :: (MonadIO m, MonadLoggerIO m) => FilePath -> m ()
+noBirdbrainedJekyll dest = do
+ let nojekyll = dest </> ".nojekyll"
+ liftIO (doesFileExist nojekyll) >>= \case
+ True -> pure ()
+ False -> do
+ log LevelInfo $ "Disabling Jekyll by writing " <> toText nojekyll
+ writeFileLBS nojekyll ""
+
+newtype StaticAssetMissing = StaticAssetMissing FilePath
+ deriving stock (Show)
+ deriving anyclass (Exception)
+
+-}
+copyDirRecursively ::
+ ( --MonadIO m,
+ --MonadUnliftIO m,
+ --MonadLoggerIO m,
+ HasCallStack
+ ) =>
+ -- | Source file path relative to CWD
+ FilePath ->
+ -- | Absolute path to source file to copy.
+ FilePath ->
+ -- | Directory *under* which the source file/dir will be copied
+ FilePath ->
+ IO ()
+copyDirRecursively srcRel srcAbs destParent = do
+ doesFileExist srcAbs >>= \case
+ True -> do
+ let b = destParent </> srcRel
+ --log LevelInfo $ toText $ "C " <> b
+ copyFileCreatingParents srcAbs b
+ False ->
+ doesDirectoryExist srcAbs >>= \case
+ False ->
+ return ()
+ -- throw $ StaticAssetMissing srcAbs
+ True -> do
+ fs <- getDirectoryFiles srcAbs ["**"]
+ forM_ fs $ \fp -> do
+ let a = srcAbs </> fp
+ b = destParent </> srcRel </> fp
+ -- log LevelInfo $ toText $ "C " <> b
+ copyFileCreatingParents a b
+ where
+ copyFileCreatingParents a b = do
+ createDirectoryIfMissing True (takeDirectory b)
+ copyFile a b
sourcephile / git / webc.git / commitdiff