--- For CompilerToF
-{-# LANGUAGE ConstraintKinds #-}
--- For Output
-{-# LANGUAGE DeriveFunctor #-}
--- For CompilerToF
-{-# LANGUAGE UndecidableInstances #-}
--- For CompilerToF
-{-# LANGUAGE AllowAmbiguousTypes #-}
+-- For Dataable instances
+{-# LANGUAGE InstanceSigs #-}
-- For Output
{-# LANGUAGE RankNTypes #-}
--- For Dataable__
-{-# LANGUAGE InstanceSigs #-}
+-- For Dataable instances
+{-# LANGUAGE UndecidableInstances #-}
module Literate.Web.Semantics.Compiler where
import Control.Applicative (Applicative (..))
-import Control.Monad (Monad (..), forM, forM_, join, sequence, (>=>))
+import Control.Monad (Monad (..), forM_)
import Control.Monad.Classes qualified as MC
-import Control.Monad.Trans.Class qualified as MT
-import Control.Monad.Trans.Reader qualified as MT
import Data.Bool
-import Data.ByteString.Lazy qualified as BSL
+import Data.ByteString.Builder qualified as BSB
import Data.Either (Either (..))
-import Data.Eq (Eq (..))
+import Data.Eq (Eq)
import Data.Foldable (toList)
-import Data.Function (const, id, ($), (.))
+import Data.Function (id, ($), (.))
import Data.Functor (Functor (..), (<$>))
-import Data.Kind (Constraint, Type)
import Data.List qualified as List
+import Data.Map.Strict qualified as Map
import Data.Maybe (Maybe (..))
-import Data.Ord (Ord (..))
+import Data.Monoid (Monoid (..))
+import Data.Ord (Ord)
import Data.Proxy (Proxy (..))
import Data.Semigroup (Semigroup (..))
-import Data.String (fromString)
import Data.Text (Text)
import Data.Text qualified as Text
-import Data.Tuple (curry, fst, snd)
+import Data.Tuple (fst, snd)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
-import Literate.Web.Syntaxes
-import Literate.Web.Types.MIME
-import Literate.Web.Types.URL
import Symantic qualified as Sym
import System.Directory qualified as Sys
import System.FilePath qualified as Sys
import System.IO qualified as Sys
import Text.Show (Show (..))
import Type.Reflection ((:~:) (..))
-import Prelude (undefined)
+
+import Literate.Web.Syntaxes
+import Literate.Web.Types.MIME
+import Literate.Web.Types.URL
-- * Type 'Compiler'
-newtype Compiler m a = Compiler {unCompiler :: {-FIXME: is m required?-}m [Output a]}
- -- deriving (Functor)
+
+-- | Interpreter building a static Web site.
+--
+-- Embed a 'Monad' @m@ to give access to a model if need be.
+newtype Compiler m a = Compiler {unCompiler :: m [Output a]}
+
+data CompilerEndpoint m a next = CompilerEndpoint
+ { compilerEndpointProof :: next :~: m BSB.Builder
+ , compilerEndpointData :: a
+ }
+type instance Sym.ToFEndpoint (Compiler m) a next = CompilerEndpoint m a next
+
+compilerEndpoint :: a -> CompilerEndpoint m a (m BSB.Builder)
+compilerEndpoint = CompilerEndpoint Refl
+
+compiler :: Compiler m (m BSB.Builder) -> Compiler m (m BSB.Builder)
+compiler = id
compile ::
MC.MonadExec Sys.IO m =>
CompilerEnv ->
Compiler m a ->
- CompilerToF a (m BSL.ByteString) ->
+ (a --> m BSB.Builder) ->
m ()
compile CompilerEnv{..} router content = do
outputs <- unCompiler router
MC.exec @Sys.IO $ Sys.removePathForcibly compilerEnvDest
- forM_ outputs $ \Output{..} -> do
- let destPath =
- ( List.intercalate "." $
- encodePath outputPath :
- ( if List.null outputExts
- then ["txt"]
- else Text.unpack . encodePathSegment <$> outputExts
- )
- )
- -- hPutStrLn stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
+ forM_ outputs $ \out -> do
+ let outFullPath = outputPathFile (outputPathRelative out)
+ -- MC.exec $ Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory outFullPath)
MC.exec @Sys.IO $
Sys.createDirectoryIfMissing True $
- compilerEnvDest Sys.</> Sys.takeDirectory destPath
- -- hPutStrLn stderr $ "write: " <> show destPath
- bsl <- outputData content
- MC.exec @Sys.IO $
- BSL.writeFile (compilerEnvDest Sys.</> destPath) $
- bsl
-
-
-compi :: Compiler m (m BSL.ByteString) -> Compiler m (m BSL.ByteString)
-compi = id
+ compilerEnvDest Sys.</> Sys.takeDirectory outFullPath
+ -- MC.exec $ Sys.hPutStrLn Sys.stderr $ "write: " <> show outFullPath
+ bsb <- outputData out content
+ MC.exec @Sys.IO do
+ Sys.withBinaryFile (compilerEnvDest Sys.</> outFullPath) Sys.WriteMode $ \h -> do
+ BSB.hPutBuilder h bsb
--- compile2 ::
--- MC.MonadExec Sys.IO m =>
--- CompilerEnv ->
--- Compiler m (m BSL.ByteString) ->
--- m ()
--- compile2 CompilerEnv{..} router = do
--- outputs <- unCompiler router
--- MC.exec @Sys.IO $ Sys.removePathForcibly compilerEnvDest
--- -- FIXME: use pipes
--- forM_ outputs $ \Output{..} -> do
--- let destPath =
--- ( List.intercalate "." $
--- encodePath outputPath :
--- ( if List.null outputExts
--- then ["txt"]
--- else Text.unpack . encodePathSegment <$> outputExts
--- )
--- )
--- -- hPutStrLn stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
--- MC.exec @Sys.IO $
--- Sys.createDirectoryIfMissing True $
--- compilerEnvDest Sys.</> Sys.takeDirectory destPath
--- -- hPutStrLn stderr $ "write: " <> show destPath
--- outputBSL <- outputData content
--- MC.exec @Sys.IO $
--- BSL.writeFile (compilerEnvDest Sys.</> destPath) $
--- outputBSL
+siteManifest :: Monad m => Compiler m a -> m [Sys.FilePath]
+siteManifest router = (outputPathFile . outputPathRelative <$>) <$> unCompiler router
-manifest :: forall m a. Monad m => Compiler m a -> m [Sys.FilePath]
-manifest router = do
+siteMap ::
+ Monad m =>
+ Compiler m a ->
+ (a --> m BSB.Builder) ->
+ m (Map.Map OutputPath (m BSB.Builder))
+siteMap router content = do
outputs <- unCompiler router
- return
- [ destPath
- | out <- outputs
- , let destPath =
- ( List.intercalate "." $
- encodePath (outputPath out) :
- ( if List.null (outputExts out)
- then ["txt"]
- else Text.unpack . encodePathSegment <$> outputExts out
- )
- )
- ]
+ return $
+ Map.fromList
+ [ (outputPathRelative out, outputData out content)
+ | out <- outputs
+ ]
+
+-- ** Type 'CompilerEnv'
+data CompilerEnv = CompilerEnv
+ { compilerEnvDest :: Sys.FilePath
+ , -- , compilerEnvSource :: Sys.FilePath
+ compilerEnvIndex :: Sys.FilePath
+ -- , compilerEnvModel :: model
+ -- , compilerEnvPath :: [PathSegment]
+ }
+ deriving (Show)
-- instance Applicative m => Applicative (Compiler m) where
-- pure = Compiler . pure . pure . pure
Compiler a <.> Compiler b = Compiler $ liftA2 (liftA2 (<.>)) a b
Compiler a <. Compiler b = Compiler $ liftA2 (liftA2 (<.)) a b
Compiler a .> Compiler b = Compiler $ liftA2 (liftA2 (.>)) a b
---instance Applicative m => Sym.AlternativeFunctor (Compiler m) where
+
+-- instance Applicative m => Sym.AlternativeFunctor (Compiler m) where
-- Compiler a <|> Compiler b = Compiler (liftA2 (<>) a b)
+
instance Applicative m => Sym.SumFunctor (Compiler m) where
Compiler a <+> Compiler b = Compiler $ liftA2 (\as bs -> (a2e <$> as) <> (b2e <$> bs)) a b
where
- a2e :: Output a -> Output (Either a b)
- a2e o = o{ outputData = outputData o . fst }
- b2e :: Output b -> Output (Either a b)
- b2e o = o{ outputData = outputData o . snd }
+ a2e :: Output a -> Output (Either a b)
+ a2e o = o{outputData = outputData o . fst}
+ b2e :: Output b -> Output (Either a b)
+ b2e o = o{outputData = outputData o . snd}
-instance (Applicative m, CompilerUnToF a) => Optionable a (Compiler m) where
- optional (Compiler ma) = Compiler $ (\as -> (a2n <$> as) <> (a2j <$> as)) <$> ma
+instance (Applicative m, Sym.ToFable a) => Optionable a (Compiler m) where
+ optional (Compiler ma) = Compiler $ (\as -> forNothing : (forJust <$> as)) <$> ma
where
- a2n :: Output a -> Output (Maybe a)
- a2n o = o{ outputData = ($ Nothing) }
- a2j :: Output a -> Output (Maybe a)
- a2j o = o{ outputData = \k -> outputData o $ compilerUnToF @(CompilerIsToF a) $ k . Just }
--- optional (Compiler ma) = Compiler $ (\as -> (a2n <$> as) <> (a2j <$> as)) <$> ma
+ forNothing :: Output (Maybe a)
+ forNothing = Output{outputPath = mempty, outputData = ($ Nothing)}
+ forJust :: Output a -> Output (Maybe a)
+ forJust o = o{outputData = \k -> outputData o $ Sym.tofOffun $ k . Just}
+
+instance Functor m => Sym.Voidable (Compiler m) where
+ void _a (Compiler ma) =
+ Compiler $
+ (\os -> (\o -> o{outputData = id}) <$> os) <$> ma
+
+-- optional (Compiler ma) = Compiler $ (\as -> forNothing : (forJust <$> as)) <$> ma
-- --pure Nothing Sym.<|> (Just <$> ma)
-- where
--- a2n :: Output a -> Output (Maybe a)
--- a2n o = o{ outputData = fst }
--- a2j :: Output a -> Output (Maybe a)
--- a2j o = o{ outputData = outputData o . snd }
---
--- ** Class 'CompilerUnToF'
-type CompilerUnToF a = CompilerUnToFIf (CompilerIsToF a) a
-class CompilerUnToFIf (t :: Bool) a where
- compilerUnToF :: (a -> next) -> CompilerToFIf t a next
-instance CompilerUnToFIf 'True () where
- compilerUnToF = ($ ())
-instance (CompilerUnToF a, CompilerUnToF b) => CompilerUnToFIf 'True (a, b) where
- compilerUnToF ab2n = compilerUnToF @(CompilerIsToF a) $ \a -> compilerUnToF @(CompilerIsToF b) $ \b -> ab2n (a,b)
-instance (CompilerUnToF a, CompilerUnToF b) => CompilerUnToFIf 'True (Either a b) where
- compilerUnToF e2n = ( compilerUnToF @(CompilerIsToF a) $ e2n . Left
- , compilerUnToF @(CompilerIsToF b) $ e2n . Right
- )
-instance CompilerUnToFIf 'False a where
- compilerUnToF = id
+-- forNothing :: Output a -> Output (Maybe a)
+-- forNothing o = o{ outputData = fst }
+-- forJust :: Output a -> Output (Maybe a)
+-- forJust o = o{ outputData = outputData o . snd }
instance
( Generic a
, Sym.RepOfEoT a
, sem ~ Compiler m
- , CompilerIsToF a ~ 'False
- , e ~ Sym.EoT (Sym.ADT a)
- , CompilerUnToF e
+ , Sym.IsToF a ~ 'False
+ , eot ~ Sym.EoT (Sym.ADT a)
+ , Sym.ToFable eot
, Functor m
- ) => Dataable__ a (Compiler m) where
- data__ :: sem (Sym.EoT (Sym.ADT a)) -> sem a
- data__ (Compiler e) = Compiler ((data__ <$>) <$> e)
+ ) =>
+ Dataable a (Compiler m)
+ where
+ dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
+ dataType (Compiler mos) = Compiler ((dataType <$>) <$> mos)
instance
( Generic a
- --, Sym.EoTOfRep a
, Sym.RepOfEoT a
, sem ~ Output
- , CompilerIsToF a ~ 'False
- --, CompilerIsToF eot ~ 'False
+ , Sym.IsToF a ~ 'False
, eot ~ Sym.EoT (Sym.ADT a)
- , CompilerUnToF eot
- ) => Dataable__ a Output where
- data__ :: sem (Sym.EoT (Sym.ADT a)) -> sem a
- data__ o = o { outputData = \k -> (outputData o) $ compilerUnToF @(CompilerIsToF eot) $ k . Sym.adtOfeot }
+ , Sym.ToFable eot
+ ) =>
+ Dataable a Output
+ where
+ dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
+ dataType o = o{outputData = \k -> (outputData o) $ Sym.tofOffun $ k . Sym.adtOfeot}
instance Applicative m => PathSegmentable (Compiler m) where
- pathSegment s = Compiler $ pure
- [
- Output
- { outputPath = [s]
- , outputExts = []
- , outputData = id
- }
- ]
+ pathSegment s =
+ Compiler $
+ pure
+ [ Output
+ { outputPath =
+ OutputPath
+ { outputPathSegs = [s]
+ , outputPathExts = []
+ }
+ , outputData = id
+ }
+ ]
instance
- ( Show a
- , Monad m
+ ( Applicative m
, n ~ m
- , end ~ m BSL.ByteString
, MimeTypes ts (MimeEncodable a)
) =>
- Responsable a ts n end (Compiler m)
+ Responsable a ts n (Compiler m)
where
- response = Compiler $ pure $
- ( \(_mediaType, MimeType (Proxy :: Proxy t)) ->
- Output
- { outputPath = []
- , outputExts = [decodePathSegment (fileExtension @t)]
- , outputData = \(Refl, Response ma) -> do
- a <- ma
- pure $ mimeEncode @_ @t a
- }
- )
- <$> toList (mimeTypesMap @ts @(MimeEncodable a))
-
--- ** Type 'CompilerEnv'
-data CompilerEnv = CompilerEnv
- { compilerEnvDest :: Sys.FilePath
- , -- , compilerEnvSource :: Sys.FilePath
- compilerEnvIndex :: Sys.FilePath
- --, compilerEnvModel :: model
- -- , compilerEnvPath :: [PathSegment]
- }
- deriving (Show)
+ response =
+ Compiler $
+ pure $
+ ( \(_mediaType, MimeType (Proxy :: Proxy t)) ->
+ Output
+ { outputPath =
+ OutputPath
+ { outputPathSegs = []
+ , outputPathExts = [decodePathSegment (fileExtension @t)]
+ }
+ , outputData = \(CompilerEndpoint Refl (Response ma)) ->
+ mimeEncode @_ @t <$> ma
+ }
+ )
+ <$> toList (mimeTypesMap @ts @(MimeEncodable a))
-- ** Type 'Output'
--- TODO: use Seq instead of []
+
data Output a = Output
- { outputPath :: [PathSegment]
- , outputExts :: [PathSegment]
- , outputData :: forall next. CompilerToF a next -> next
- --, outputBSL :: BSL.ByteString
- -- , outputType :: MimeType (MimeEncodable a)
+ { outputPath :: OutputPath
+ , outputData :: forall next. (a --> next) -> next
}
--- instance Sym.SumFunctor Output where
--- a <+> b = Output
--- { outputPath = outputPath a <> outputPath b
--- , outputExts = outputExts a <> outputExts b
--- , outputData = \(a2n, b2n) -> outputData a a2n
--- }
-instance Sym.ProductFunctor Output where
- a <.> b = Output
- { outputPath = outputPath a <> outputPath b
- , outputExts = outputExts a <> outputExts b
- , outputData = outputData b . outputData a
- }
- a <. b = Output
- { outputPath = outputPath a <> outputPath b
- , outputExts = outputExts a <> outputExts b
- , outputData = outputData b . outputData a
- }
- a .> b = Output
- { outputPath = outputPath a <> outputPath b
- , outputExts = outputExts a <> outputExts b
- , outputData = outputData b . outputData a
- }
--- deriving (Functor, Show)
--- instance Applicative Output where
--- pure a =
--- Output
--- { outputPath = []
--- , outputExts = []
--- , outputData = a
--- --, outputBSL = ""
--- -- , outputType = mediaType @PlainText
--- }
--- oa2b <*> oa =
--- Output
--- { outputPath = outputPath oa2b <> outputPath oa
--- , outputExts = outputExts oa2b <> outputExts oa
--- , outputData = outputData oa2b (outputData oa)
--- --, outputBSL = outputBSL oa2b <> outputBSL oa
--- }
+outputBuilder :: Output a -> (a --> m BSB.Builder) -> m BSB.Builder
+outputBuilder = outputData
+outputPathRelative :: Output a -> OutputPath
+outputPathRelative out
+ | List.null (outputPathExts outPath) = outPath{outputPathExts = ["txt"]}
+ | otherwise = outPath
+ where
+ outPath = outputPath out
--- * Type family 'CompilerToF'
-type CompilerToF a next = CompilerToFIf (CompilerIsToF a) a next
-type family CompilerToFIf t a next :: Type where
--- For '<.>': curry.
- CompilerToFIf 'True (a, b) next = CompilerToF a (CompilerToF b next)
--- For '<+>', request both branches.
- CompilerToFIf 'True (Either l r) next = (CompilerToF l next, CompilerToF r next)
- --CompilerToFIf 'True (Maybe a) next = (CompilerToF () next, CompilerToF a next)
--- Useless to ask '()' as argument.
- CompilerToFIf 'True () next = next
--- Enable a different return value for each function.
- CompilerToFIf 'True (Sym.Endpoint end a) next = (next :~: end, a)
--- Everything else becomes a new argument.
- CompilerToFIf 'False a next = a -> next
+-- *** Type 'OutputPath'
+data OutputPath = OutputPath
+ { outputPathSegs :: [PathSegment]
+ , outputPathExts :: [PathSegment]
+ }
+ deriving (Eq, Ord, Show)
+outputPathFile :: OutputPath -> Sys.FilePath
+outputPathFile outPath =
+ List.intercalate "." $
+ encodePath (outputPathSegs outPath)
+ : (Text.unpack . encodePathSegment <$> outputPathExts outPath)
--- | This 'Bool' is added to 'ToFIf' to avoid overlapping instances.
-type family CompilerIsToF a :: Bool where
- CompilerIsToF () = 'True
- CompilerIsToF (a, b) = 'True
- CompilerIsToF (Either l r) = 'True
- --CompilerIsToF (Maybe a) = 'True
- CompilerIsToF (Sym.Endpoint end a) = 'True
- CompilerIsToF a = 'False
+instance Semigroup OutputPath where
+ x <> y =
+ OutputPath
+ { outputPathSegs = outputPathSegs x <> outputPathSegs y
+ , outputPathExts = outputPathExts x <> outputPathExts y
+ }
+instance Monoid OutputPath where
+ mempty = OutputPath{outputPathSegs = [], outputPathExts = []}
+instance Sym.ProductFunctor Output where
+ a <.> b =
+ Output
+ { outputPath = outputPath a <> outputPath b
+ , outputData = outputData b . outputData a
+ }
+ a <. b =
+ Output
+ { outputPath = outputPath a <> outputPath b
+ , outputData = outputData b . outputData a
+ }
+ a .> b =
+ Output
+ { outputPath = outputPath a <> outputPath b
+ , outputData = outputData b . outputData a
+ }
--- -- pathSegments _ss = Compiler $
--- -- MT.ReaderT $ \s ->
--- -- -- TODO: assert Set.member s ss
--- -- lift $
--- -- MT.modify' $ \st ->
--- -- st{compilerStatePath = compilerStatePath st </> Text.unpack (encodePathSegment s)}
---
--- {-
--- instance
--- TypeError (
--- 'Text "The instance (Capturable a Compiler)"
--- ':$$: 'Text "is disabled when compiling to a static Web site."
--- ':$$: 'Text "You can use (whenInterpreter @Compiler siteNotUsingCapturable siteUsingCapturable)"
--- ':$$: 'Text "to replace calls to any method of Capturable."
--- ) => Capturable a Compiler where
--- capturePathSegment = undefined
--- instance
--- TypeError (
--- 'Text "The instance (Capturable a (Reader model Compiler))"
--- ':$$: 'Text "is disabled when compiling to a static Web site."
--- ':$$: 'Text "You can use (whenInterpreter @(Reader model Compiler) siteNotUsingCapturable siteUsingCapturable)"
--- ':$$: 'Text "to replace calls to any method of Capturable."
--- ) => Capturable a (Reader model Compiler) where
--- capturePathSegment = undefined
--- -}
---
--- -- choosePathSegments _s = Compiler $ MT.ReaderT $ \s -> return $ Endo (List.reverse s <>)
--- {-
--- instance Capturable Compiler where
--- type CapturableConstraint Compiler =
--- capturePathSegment _n = Compiler $ MT.ReaderT $ \s ->
--- lift $ MT.modify' $ \st ->
--- st{compilerStatePath = compilerStatePath st </> Text.unpack (encodePathSegment s)}
--- -}
--- {-
--- instance Copyable Compiler where
--- copy path = Compiler $
--- lift $
--- MT.ReaderT $ \env -> do
--- lift $ do
--- doesPathExist (compilerEnvSource env </> path) >>= \case
--- True -> do
--- Sys.hPutStrLn Sys.stderr $
--- "staticCopy: "
--- <> show
--- ( (compilerEnvSource env </> path)
--- , (compilerEnvDest env </> path)
--- )
--- copyDirRecursively
--- path
--- (compilerEnvSource env </> path)
--- (compilerEnvDest env)
--- False -> do
--- Sys.hPutStrLn Sys.stderr $ "error: path does not exist: " <> (compilerEnvSource env </> path)
--- instance Encodable fmt a => Contentable fmt a Compiler where
--- content = Compiler $
--- MT.ReaderT $ \a -> MT.ReaderT $ \env -> do
--- st <- MT.get
--- let destPath = compilerEnvDest env </> compilerStatePath st
--- lift $ do
--- -- Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
--- createDirectoryIfMissing True (Sys.takeDirectory destPath)
--- -- Sys.hPutStrLn Sys.stderr $ "write: " <> show destPath
--- BSL.writeFile destPath $ encode @fmt a
--- -}
--- --instance Endable Compiler where
--- -- end = Compiler $ return $ Endo id
---
--- --pathSegments _cs = Compiler $ MT.ReaderT $ \s -> return $ Endo (s :)
--- -- instance Fileable Compiler where
--- -- type FileableConstraint Compiler = Typeable
--- -- static = Compiler $ MT.ReaderT $ \_a ->
--- -- return $ Endo (\x -> x)
---
--- {-
--- -- * The 'Compiler' interpreter
---
--- -- | Create files according to the given model of type 'a'.
--- newtype Compiler a = Compiler
--- { unCompiler :: [Comp a]
--- }
--- deriving (Show, Functor)
---
--- 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 >>=)
---
-- compile :: Show a => Renderable a => Compiler a -> CompilerEnv -> Sys.IO ()
-- compile compiler conf@CompilerEnv{..} = do
-- createDirectoryIfMissing True compilerEnvDest
-- Sys.hPutStrLn Sys.stderr $ "error: path does not exist: " <> (compilerEnvSource </> staticPath)
-- -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
-- Right bs -> do
--- let destPath = compilerEnvDest </> routePath
+-- let outputFullPath = compilerEnvDest </> routePath
-- {-
-- maybe (routePath </> compilerEnvIndex)
-- (routePath Sys.FilePath.<.>)
-- (compType comp)
-- -}
--- -- Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
--- createDirectoryIfMissing True (Sys.takeDirectory destPath)
--- -- Sys.hPutStrLn Sys.stderr $ "write: " <> show destPath
--- BSL.writeFile destPath bs
---
--- -- ** Class 'Renderable'
--- class Renderable a where
--- render :: a -> Either Sys.FilePath BSL.ByteString
--- instance Renderable () where
--- render () =
--- --Left $ pathOfPathSegments compPathSegments
--- Right BSL.empty
---
--- -- ** Type 'Comp'
--- data Comp a = Comp
--- { compPathSegments :: [PathSegment] -- TODO: Endo? Seq?
--- , compData :: a
--- -- , compType :: MimeType (MimeEncodable a)
--- }
--- deriving instance Eq a => Eq (Comp a)
--- deriving instance Ord a => Ord (Comp a)
--- deriving instance Show a => Show (Comp a)
--- deriving instance Functor Comp
--- instance Applicative Comp where
--- pure compData =
--- Comp
--- { compPathSegments = []
--- , compData
--- -- , compType = mediaType @PlainText
--- }
--- f <*> x =
--- Comp
--- { compPathSegments = compPathSegments f <> compPathSegments x
--- , compData = compData f (compData x)
--- -- , compType = compType f <> compType 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 { compPathSegments = []
--- , compData = Nothing
--- -- , compType = Nothing
--- } :
--- ((Just <$>) <$> unCompiler x)
--- instance PathSegmentable Compiler where
--- pathSegment s = Compiler
--- [
--- Comp
--- { compPathSegments = [s]
--- , compData = ()
--- -- , compType = PlainText
--- }
--- ]
--- pathSegments ss =
--- Compiler $
--- [ Comp{ compPathSegments = [s]
--- , compData = s
--- -- , compType = Nothing
--- }
--- | s <- toList ss
--- ]
--- instance ContentTypeable PlainText () Compiler where
--- contentType =
--- Compiler
--- [ Comp
--- { compPathSegments = []
--- , compData = ()
--- --, compType = mediaType @PlainText
--- }
--- ]
---
--- -- 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
--- -- capturePathSegment n = Compiler $ [Comp [n] n]
--- -- instance Constantable c Compiler where
--- -- constant = pure
--- -}
---
+-- -- Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory outputFullPath)
+-- createDirectoryIfMissing True (Sys.takeDirectory outputFullPath)
+-- -- Sys.hPutStrLn Sys.stderr $ "write: " <> show outputFullPath
+-- BSL.writeFile outputFullPath bs
+
copyDirRecursively ::
- ( --MonadIO m,
- --MonadUnliftIO m,
- --MonadLoggerIO m,
- HasCallStack
- ) =>
+ HasCallStack =>
-- | Source file path relative to CWD
Sys.FilePath ->
-- | Absolute path to source file to copy.
copyDirRecursively srcRel srcAbs destParent = do
Sys.doesFileExist srcAbs >>= \case
True -> do
- Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a file", srcAbs)
+ Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a file" :: Text, srcAbs)
copyFileCreatingParents srcAbs (destParent Sys.</> srcRel)
False ->
Sys.doesDirectoryExist srcAbs >>= \case
False -> do
- Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is neither a file nor directory", srcAbs)
+ Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is neither a file nor directory" :: Text, srcAbs)
return ()
-- throw $ StaticAssetMissing srcAbs
True -> do
- Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a directory", srcAbs)
+ Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a directory" :: Text, srcAbs)
Sys.createDirectoryIfMissing True (destParent Sys.</> srcRel)
fs <- Sys.getDirectoryFiles srcAbs ["**"]
forM_ fs $ \fp -> do
- let a = srcAbs Sys.</> fp
- b = destParent Sys.</> srcRel Sys.</> fp
+ let
+ a = srcAbs Sys.</> fp
+ b = destParent Sys.</> srcRel Sys.</> fp
copyFileCreatingParents a b
where
copyFileCreatingParents a b = do
sourcephile / git / haskell / literate-web.git / blobdiff