fix(live): support custom `Content-Type`

[haskell/literate-web.git] / src / Literate / Web / Semantics / Compiler.hs

diff --git a/src/Literate/Web/Semantics/Compiler.hs b/src/Literate/Web/Semantics/Compiler.hs
index 1d093a55e1e93f6852bfbe27c202fe1754021ffc..868936d62731da5b25d502690ec233cce4ef5425 100644 (file)
--- a/src/Literate/Web/Semantics/Compiler.hs
+++ b/src/Literate/Web/Semantics/Compiler.hs
@@ -11,16 +11,16 @@ import Control.Applicative (Applicative (..))
 import Control.Monad (Monad (..), forM_)
 import Control.Monad.Classes qualified as MC
 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.Foldable (toList)
-import Data.Function (id, ($), (.))
+import Data.Function (id, ($), (&), (.))
 import Data.Functor (Functor (..), (<$>))
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
-import Data.Maybe (Maybe (..))
-import Data.Monoid (Monoid (..))
+import Data.Maybe (Maybe (..), fromMaybe)
+import Data.Monoid (Last (..), Monoid (..))
 import Data.Ord (Ord)
 import Data.Proxy (Proxy (..))
 import Data.Semigroup (Semigroup (..))
@@ -48,19 +48,23 @@ import Literate.Web.Types.URL
 -- Embed a 'Monad' @m@ to give access to a model if need be.
 newtype Compiler m a = Compiler {unCompiler :: m [Output a]}
 
-type instance Sym.ToFEndpoint (Compiler m) a next = (next :~: m BSL.ByteString, 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 -> Sym.ToFEndpoint (Compiler m) a (m BSL.ByteString)
-compilerEndpoint = (Refl,)
+compilerEndpoint :: a -> CompilerEndpoint m a (m BSB.Builder)
+compilerEndpoint = CompilerEndpoint Refl
 
-compiler :: Compiler m (m BSL.ByteString) -> Compiler m (m BSL.ByteString)
+compiler :: Compiler m (m BSB.Builder) -> Compiler m (m BSB.Builder)
 compiler = id
 
 compile ::
   MC.MonadExec Sys.IO m =>
   CompilerEnv ->
   Compiler m a ->
-  (a --> m BSL.ByteString) ->
+  (a --> m BSB.Builder) ->
   m ()
 compile CompilerEnv{..} router content = do
   outputs <- unCompiler router
@@ -72,8 +76,10 @@ compile CompilerEnv{..} router content = do
       Sys.createDirectoryIfMissing True $
         compilerEnvDest Sys.</> Sys.takeDirectory outFullPath
     -- MC.exec $ Sys.hPutStrLn Sys.stderr $ "write: " <> show outFullPath
-    bsl <- outputData out content
-    MC.exec @Sys.IO $ BSL.writeFile (compilerEnvDest Sys.</> outFullPath) bsl
+    bsb <- outputData out content
+    MC.exec @Sys.IO do
+      Sys.withBinaryFile (compilerEnvDest Sys.</> outFullPath) Sys.WriteMode $ \h -> do
+        BSB.hPutBuilder h bsb
 
 siteManifest :: Monad m => Compiler m a -> m [Sys.FilePath]
 siteManifest router = (outputPathFile . outputPathRelative <$>) <$> unCompiler router
@@ -81,13 +87,18 @@ siteManifest router = (outputPathFile . outputPathRelative <$>) <$> unCompiler r
 siteMap ::
   Monad m =>
   Compiler m a ->
-  (a --> m BSL.ByteString) ->
-  m (Map.Map OutputPath (m BSL.ByteString))
+  (a --> m BSB.Builder) ->
+  m (Map.Map OutputPath (MediaType, m BSB.Builder))
 siteMap router content = do
   outputs <- unCompiler router
   return $
     Map.fromList
-      [ (outputPathRelative out, outputData out content)
+      [ ( outputPathRelative out
+        ,
+          ( outputType out & getLast & fromMaybe (mediaTypeFor (Proxy @HTML))
+          , outputData out content
+          )
+        )
       | out <- outputs
       ]
 
@@ -138,10 +149,20 @@ instance (Applicative m, Sym.ToFable a) => Optionable a (Compiler m) where
   optional (Compiler ma) = Compiler $ (\as -> forNothing : (forJust <$> as)) <$> ma
     where
       forNothing :: Output (Maybe a)
-      forNothing = Output{outputPath = mempty, outputData = ($ Nothing)}
+      forNothing =
+        Output
+          { outputPath = mempty
+          , outputType = 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
@@ -185,6 +206,7 @@ instance Applicative m => PathSegmentable (Compiler m) where
                   { outputPathSegs = [s]
                   , outputPathExts = []
                   }
+            , outputType = mempty
             , outputData = id
             }
         ]
@@ -198,14 +220,16 @@ instance
   response =
     Compiler $
       pure $
-        ( \(_mediaType, MimeType (Proxy :: Proxy t)) ->
+        ( \(mediaType_, MimeType (Proxy :: Proxy t)) ->
             Output
               { outputPath =
                   OutputPath
                     { outputPathSegs = []
                     , outputPathExts = [decodePathSegment (fileExtension @t)]
                     }
-              , outputData = \(Refl, Response ma) -> mimeEncode @_ @t <$> ma
+              , outputType = Last $ Just mediaType_
+              , outputData = \(CompilerEndpoint Refl (Response ma)) ->
+                  mimeEncode @_ @t <$> ma
               }
         )
           <$> toList (mimeTypesMap @ts @(MimeEncodable a))
@@ -214,11 +238,12 @@ instance
 
 data Output a = Output
   { outputPath :: OutputPath
+  , outputType :: Last MediaType
   , outputData :: forall next. (a --> next) -> next
   }
 
-outputBSL :: Output a -> (a --> m BSL.ByteString) -> m BSL.ByteString
-outputBSL = outputData
+outputBuilder :: Output a -> (a --> m BSB.Builder) -> m BSB.Builder
+outputBuilder = outputData
 
 outputPathRelative :: Output a -> OutputPath
 outputPathRelative out
@@ -232,7 +257,7 @@ data OutputPath = OutputPath
   { outputPathSegs :: [PathSegment]
   , outputPathExts :: [PathSegment]
   }
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Show)
 
 outputPathFile :: OutputPath -> Sys.FilePath
 outputPathFile outPath =
@@ -253,16 +278,19 @@ instance Sym.ProductFunctor Output where
   a <.> b =
     Output
       { outputPath = outputPath a <> outputPath b
+      , outputType = outputType a <> outputType b
       , outputData = outputData b . outputData a
       }
   a <. b =
     Output
       { outputPath = outputPath a <> outputPath b
+      , outputType = outputType a <> outputType b
       , outputData = outputData b . outputData a
       }
   a .> b =
     Output
       { outputPath = outputPath a <> outputPath b
+      , outputType = outputType a <> outputType b
       , outputData = outputData b . outputData a
       }