]> Git — Sourcephile - haskell/literate-web.git/blob - src/Literate/Web/Semantics/Compiler.hs
feat(live): init `Literate.Web.Live`
[haskell/literate-web.git] / src / Literate / Web / Semantics / Compiler.hs
1 -- For Dataable instances
2 {-# LANGUAGE InstanceSigs #-}
3 -- For Output
4 {-# LANGUAGE RankNTypes #-}
5 -- For Dataable instances
6 {-# LANGUAGE UndecidableInstances #-}
7
8 module Literate.Web.Semantics.Compiler where
9
10 import Control.Applicative (Applicative (..))
11 import Control.Monad (Monad (..), forM_)
12 import Control.Monad.Classes qualified as MC
13 import Data.Bool
14 import Data.ByteString.Builder qualified as BSB
15 import Data.Either (Either (..))
16 import Data.Eq (Eq)
17 import Data.Foldable (toList)
18 import Data.Function (id, ($), (.))
19 import Data.Functor (Functor (..), (<$>))
20 import Data.List qualified as List
21 import Data.Map.Strict qualified as Map
22 import Data.Maybe (Maybe (..))
23 import Data.Monoid (Monoid (..))
24 import Data.Ord (Ord)
25 import Data.Proxy (Proxy (..))
26 import Data.Semigroup (Semigroup (..))
27 import Data.Text (Text)
28 import Data.Text qualified as Text
29 import Data.Tuple (fst, snd)
30 import GHC.Generics (Generic)
31 import GHC.Stack (HasCallStack)
32 import Symantic qualified as Sym
33 import System.Directory qualified as Sys
34 import System.FilePath qualified as Sys
35 import System.FilePattern.Directory qualified as Sys
36 import System.IO qualified as Sys
37 import Text.Show (Show (..))
38 import Type.Reflection ((:~:) (..))
39
40 import Literate.Web.Syntaxes
41 import Literate.Web.Types.MIME
42 import Literate.Web.Types.URL
43
44 -- * Type 'Compiler'
45
46 -- | Interpreter building a static Web site.
47 --
48 -- Embed a 'Monad' @m@ to give access to a model if need be.
49 newtype Compiler m a = Compiler {unCompiler :: m [Output a]}
50
51 data CompilerEndpoint m a next = CompilerEndpoint
52 { compilerEndpointProof :: next :~: m BSB.Builder
53 , compilerEndpointData :: a
54 }
55 type instance Sym.ToFEndpoint (Compiler m) a next = CompilerEndpoint m a next
56
57 compilerEndpoint :: a -> CompilerEndpoint m a (m BSB.Builder)
58 compilerEndpoint = CompilerEndpoint Refl
59
60 compiler :: Compiler m (m BSB.Builder) -> Compiler m (m BSB.Builder)
61 compiler = id
62
63 compile ::
64 MC.MonadExec Sys.IO m =>
65 CompilerEnv ->
66 Compiler m a ->
67 (a --> m BSB.Builder) ->
68 m ()
69 compile CompilerEnv{..} router content = do
70 outputs <- unCompiler router
71 MC.exec @Sys.IO $ Sys.removePathForcibly compilerEnvDest
72 forM_ outputs $ \out -> do
73 let outFullPath = outputPathFile (outputPathRelative out)
74 -- MC.exec $ Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory outFullPath)
75 MC.exec @Sys.IO $
76 Sys.createDirectoryIfMissing True $
77 compilerEnvDest Sys.</> Sys.takeDirectory outFullPath
78 -- MC.exec $ Sys.hPutStrLn Sys.stderr $ "write: " <> show outFullPath
79 bsb <- outputData out content
80 MC.exec @Sys.IO do
81 Sys.withBinaryFile (compilerEnvDest Sys.</> outFullPath) Sys.WriteMode $ \h -> do
82 BSB.hPutBuilder h bsb
83
84 siteManifest :: Monad m => Compiler m a -> m [Sys.FilePath]
85 siteManifest router = (outputPathFile . outputPathRelative <$>) <$> unCompiler router
86
87 siteMap ::
88 Monad m =>
89 Compiler m a ->
90 (a --> m BSB.Builder) ->
91 m (Map.Map OutputPath (m BSB.Builder))
92 siteMap router content = do
93 outputs <- unCompiler router
94 return $
95 Map.fromList
96 [ (outputPathRelative out, outputData out content)
97 | out <- outputs
98 ]
99
100 -- ** Type 'CompilerEnv'
101 data CompilerEnv = CompilerEnv
102 { compilerEnvDest :: Sys.FilePath
103 , -- , compilerEnvSource :: Sys.FilePath
104 compilerEnvIndex :: Sys.FilePath
105 -- , compilerEnvModel :: model
106 -- , compilerEnvPath :: [PathSegment]
107 }
108 deriving (Show)
109
110 -- instance Applicative m => Applicative (Compiler m) where
111 -- pure = Compiler . pure . pure . pure
112 -- liftA2 f (Compiler a) (Compiler b) = Compiler (liftA2 (liftA2 (liftA2 f)) a b)
113 -- instance Monad m => Monad (Compiler m) where
114 -- return = pure
115 -- Compiler mloa >>= a2mlob =
116 -- Compiler $ do
117 -- mloa >>= \loa ->
118 -- (join <$>) $
119 -- forM loa $ \oa -> do
120 -- lob <- unCompiler $ a2mlob $ outputData oa
121 -- forM lob $ \ob ->
122 -- return
123 -- ob
124 -- { outputPath = outputPath oa <> outputPath ob
125 -- , outputExts = outputExts oa <> outputExts ob
126 -- }
127 instance Applicative m => Sym.ProductFunctor (Compiler m) where
128 Compiler a <.> Compiler b = Compiler $ liftA2 (liftA2 (<.>)) a b
129 Compiler a <. Compiler b = Compiler $ liftA2 (liftA2 (<.)) a b
130 Compiler a .> Compiler b = Compiler $ liftA2 (liftA2 (.>)) a b
131
132 -- instance Applicative m => Sym.AlternativeFunctor (Compiler m) where
133 -- Compiler a <|> Compiler b = Compiler (liftA2 (<>) a b)
134
135 instance Applicative m => Sym.SumFunctor (Compiler m) where
136 Compiler a <+> Compiler b = Compiler $ liftA2 (\as bs -> (a2e <$> as) <> (b2e <$> bs)) a b
137 where
138 a2e :: Output a -> Output (Either a b)
139 a2e o = o{outputData = outputData o . fst}
140 b2e :: Output b -> Output (Either a b)
141 b2e o = o{outputData = outputData o . snd}
142
143 instance (Applicative m, Sym.ToFable a) => Optionable a (Compiler m) where
144 optional (Compiler ma) = Compiler $ (\as -> forNothing : (forJust <$> as)) <$> ma
145 where
146 forNothing :: Output (Maybe a)
147 forNothing = Output{outputPath = mempty, outputData = ($ Nothing)}
148 forJust :: Output a -> Output (Maybe a)
149 forJust o = o{outputData = \k -> outputData o $ Sym.tofOffun $ k . Just}
150
151 -- optional (Compiler ma) = Compiler $ (\as -> forNothing : (forJust <$> as)) <$> ma
152 -- --pure Nothing Sym.<|> (Just <$> ma)
153 -- where
154 -- forNothing :: Output a -> Output (Maybe a)
155 -- forNothing o = o{ outputData = fst }
156 -- forJust :: Output a -> Output (Maybe a)
157 -- forJust o = o{ outputData = outputData o . snd }
158
159 instance
160 ( Generic a
161 , Sym.RepOfEoT a
162 , sem ~ Compiler m
163 , Sym.IsToF a ~ 'False
164 , eot ~ Sym.EoT (Sym.ADT a)
165 , Sym.ToFable eot
166 , Functor m
167 ) =>
168 Dataable a (Compiler m)
169 where
170 dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
171 dataType (Compiler mos) = Compiler ((dataType <$>) <$> mos)
172 instance
173 ( Generic a
174 , Sym.RepOfEoT a
175 , sem ~ Output
176 , Sym.IsToF a ~ 'False
177 , eot ~ Sym.EoT (Sym.ADT a)
178 , Sym.ToFable eot
179 ) =>
180 Dataable a Output
181 where
182 dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
183 dataType o = o{outputData = \k -> (outputData o) $ Sym.tofOffun $ k . Sym.adtOfeot}
184 instance Applicative m => PathSegmentable (Compiler m) where
185 pathSegment s =
186 Compiler $
187 pure
188 [ Output
189 { outputPath =
190 OutputPath
191 { outputPathSegs = [s]
192 , outputPathExts = []
193 }
194 , outputData = id
195 }
196 ]
197 instance
198 ( Applicative m
199 , n ~ m
200 , MimeTypes ts (MimeEncodable a)
201 ) =>
202 Responsable a ts n (Compiler m)
203 where
204 response =
205 Compiler $
206 pure $
207 ( \(_mediaType, MimeType (Proxy :: Proxy t)) ->
208 Output
209 { outputPath =
210 OutputPath
211 { outputPathSegs = []
212 , outputPathExts = [decodePathSegment (fileExtension @t)]
213 }
214 , outputData = \(CompilerEndpoint Refl (Response ma)) ->
215 mimeEncode @_ @t <$> ma
216 }
217 )
218 <$> toList (mimeTypesMap @ts @(MimeEncodable a))
219
220 -- ** Type 'Output'
221
222 data Output a = Output
223 { outputPath :: OutputPath
224 , outputData :: forall next. (a --> next) -> next
225 }
226
227 outputBuilder :: Output a -> (a --> m BSB.Builder) -> m BSB.Builder
228 outputBuilder = outputData
229
230 outputPathRelative :: Output a -> OutputPath
231 outputPathRelative out
232 | List.null (outputPathExts outPath) = outPath{outputPathExts = ["txt"]}
233 | otherwise = outPath
234 where
235 outPath = outputPath out
236
237 -- *** Type 'OutputPath'
238 data OutputPath = OutputPath
239 { outputPathSegs :: [PathSegment]
240 , outputPathExts :: [PathSegment]
241 }
242 deriving (Eq, Ord, Show)
243
244 outputPathFile :: OutputPath -> Sys.FilePath
245 outputPathFile outPath =
246 List.intercalate "." $
247 encodePath (outputPathSegs outPath)
248 : (Text.unpack . encodePathSegment <$> outputPathExts outPath)
249
250 instance Semigroup OutputPath where
251 x <> y =
252 OutputPath
253 { outputPathSegs = outputPathSegs x <> outputPathSegs y
254 , outputPathExts = outputPathExts x <> outputPathExts y
255 }
256 instance Monoid OutputPath where
257 mempty = OutputPath{outputPathSegs = [], outputPathExts = []}
258
259 instance Sym.ProductFunctor Output where
260 a <.> b =
261 Output
262 { outputPath = outputPath a <> outputPath b
263 , outputData = outputData b . outputData a
264 }
265 a <. b =
266 Output
267 { outputPath = outputPath a <> outputPath b
268 , outputData = outputData b . outputData a
269 }
270 a .> b =
271 Output
272 { outputPath = outputPath a <> outputPath b
273 , outputData = outputData b . outputData a
274 }
275
276 -- compile :: Show a => Renderable a => Compiler a -> CompilerEnv -> Sys.IO ()
277 -- compile compiler conf@CompilerEnv{..} = do
278 -- createDirectoryIfMissing True compilerEnvDest
279 -- let router = unCompiler compiler
280 -- when (null router) $
281 -- error "no router, nothing to compile"
282 -- -- Sys.hPutStrLn Sys.stderr $ "conf: " <> show conf
283 -- -- forM_ router $ \comp -> do
284 -- -- Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
285 -- forM_ router $ \Comp{..} -> do
286 -- -- Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
287 -- let routePath = pathOfPathSegments compPathSegments
288 -- in case render compData of
289 -- Left staticPath ->
290 -- doesPathExist (compilerEnvSource </> staticPath) >>= \case
291 -- True -> do
292 -- -- TODO: In current branch, we don't expect this to be a directory.
293 -- -- Although the user may pass it, but review before merge.
294 -- Sys.hPutStrLn Sys.stderr $
295 -- "staticCopy: "
296 -- <> show
297 -- ( (compilerEnvSource </> staticPath)
298 -- , (compilerEnvDest </> staticPath)
299 -- )
300 -- copyDirRecursively
301 -- staticPath
302 -- (compilerEnvSource </> staticPath)
303 -- (compilerEnvDest)
304 -- False -> do
305 -- Sys.hPutStrLn Sys.stderr $ "error: path does not exist: " <> (compilerEnvSource </> staticPath)
306 -- -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
307 -- Right bs -> do
308 -- let outputFullPath = compilerEnvDest </> routePath
309 -- {-
310 -- maybe (routePath </> compilerEnvIndex)
311 -- (routePath Sys.FilePath.<.>)
312 -- (compType comp)
313 -- -}
314 -- -- Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory outputFullPath)
315 -- createDirectoryIfMissing True (Sys.takeDirectory outputFullPath)
316 -- -- Sys.hPutStrLn Sys.stderr $ "write: " <> show outputFullPath
317 -- BSL.writeFile outputFullPath bs
318
319 copyDirRecursively ::
320 HasCallStack =>
321 -- | Source file path relative to CWD
322 Sys.FilePath ->
323 -- | Absolute path to source file to copy.
324 Sys.FilePath ->
325 -- | Directory *under* which the source file/dir will be copied
326 Sys.FilePath ->
327 Sys.IO ()
328 copyDirRecursively srcRel srcAbs destParent = do
329 Sys.doesFileExist srcAbs >>= \case
330 True -> do
331 Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a file" :: Text, srcAbs)
332 copyFileCreatingParents srcAbs (destParent Sys.</> srcRel)
333 False ->
334 Sys.doesDirectoryExist srcAbs >>= \case
335 False -> do
336 Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is neither a file nor directory" :: Text, srcAbs)
337 return ()
338 -- throw $ StaticAssetMissing srcAbs
339 True -> do
340 Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a directory" :: Text, srcAbs)
341 Sys.createDirectoryIfMissing True (destParent Sys.</> srcRel)
342 fs <- Sys.getDirectoryFiles srcAbs ["**"]
343 forM_ fs $ \fp -> do
344 let
345 a = srcAbs Sys.</> fp
346 b = destParent Sys.</> srcRel Sys.</> fp
347 copyFileCreatingParents a b
348 where
349 copyFileCreatingParents a b = do
350 Sys.createDirectoryIfMissing True (Sys.takeDirectory b)
351 Sys.copyFile a b