feat(syn): add `coding`

diff --git a/src/Literate/Web/Semantics/Compiler.hs b/src/Literate/Web/Semantics/Compiler.hs
index 09b283e60f00384a6b38da18096dc92a7e0df1d5..d62b9ba500e129cc9be047bb8f4c55e9576744c6 100644 (file)
--- a/src/Literate/Web/Semantics/Compiler.hs
+++ b/src/Literate/Web/Semantics/Compiler.hs
@@ -148,6 +148,11 @@ instance (Applicative m, Sym.ToFable a) => Optionable a (Compiler m) where
       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

diff --git a/src/Literate/Web/Syntaxes.hs b/src/Literate/Web/Syntaxes.hs
index 22ecf99c01cb246ffba862c23594e0cc7bbe2906..7b5d36b895be82afcb7606c1fabf04f7eea830f8 100644 (file)
--- a/src/Literate/Web/Syntaxes.hs
+++ b/src/Literate/Web/Syntaxes.hs
@@ -24,14 +24,14 @@ module Literate.Web.Syntaxes (
 ) where
 
 import Control.Applicative (Applicative)
-import Control.Monad (Monad)
+import Control.Monad (Monad (..))
 import Control.Monad.Classes qualified as MC
 import Control.Monad.Trans.Class as MT
 import Data.Bool (Bool (..))
 import Data.ByteString.Lazy qualified as BSL
 import Data.Either (Either (..))
 import Data.Function ((.))
-import Data.Functor as Functor
+import Data.Functor (Functor)
 import Data.Kind (Constraint, Type)
 import Data.Maybe (Maybe)
 import Data.Typeable (Typeable)
@@ -48,6 +48,7 @@ import Symantic.Syntaxes (
   SumFunctor (..),
   ToFEndpoint,
   ToFable,
+  Voidable (..),
   dataType,
   pattern (:!:),
   type (-->),
@@ -69,7 +70,7 @@ class PathSegmentable sem where
   -- pathSegment :: PathSegment -> sem a -> sem a
 
   pathSegment :: PathSegment -> sem ()
-  default pathSegment :: (FromDerived PathSegmentable sem) => PathSegment -> sem ()
+  default pathSegment :: FromDerived PathSegmentable sem => PathSegment -> sem ()
   -- default pathSegment :: IsoFunctor sem => PathSegment -> sem ()
   -- pathSegment s = Iso (const ()) (const s) <%> pathSegments (Set.singleton s)
   pathSegment = liftDerived . pathSegment
@@ -92,7 +93,7 @@ data instance Data PathSegmentable sem a where
 -- ChoosePathSegments :: Set [PathSegment] -> Data PathSegmentable sem [PathSegment]
 
 -- | Initial to final algebra.
-instance (PathSegmentable sem) => Derivable (Data PathSegmentable sem) where
+instance PathSegmentable sem => Derivable (Data PathSegmentable sem) where
   derive = \case
     PathSegment x -> pathSegment x
 
@@ -101,7 +102,7 @@ instance (PathSegmentable sem) => Derivable (Data PathSegmentable sem) where
 -- ChoosePathSegments x -> choosePathSegments x
 
 -- | Final to initial algebra.
-instance (PathSegmentable sem) => PathSegmentable (SomeData sem) where
+instance PathSegmentable sem => PathSegmentable (SomeData sem) where
   pathSegment = SomeData . PathSegment
 
 -- pathSegments = SomeData . PathSegments
@@ -109,13 +110,13 @@ instance (PathSegmentable sem) => PathSegmentable (SomeData sem) where
 -- choosePathSegments = SomeData . ChoosePathSegments
 
 -- | Convenient alias for an @index.html@ page.
-index :: (PathSegmentable sem) => sem ()
+index :: PathSegmentable sem => sem ()
 index = pathSegment "index.html"
 
 -- | Convenient alias for prefixing with a 'pathSegment'.
 (</>) ::
-  (ProductFunctor sem) =>
-  (PathSegmentable sem) =>
+  ProductFunctor sem =>
+  PathSegmentable sem =>
   PathSegment ->
   sem a ->
   sem a
@@ -137,8 +138,8 @@ class Capturable a sem where
   type Captured a sem = a
   capturePathSegment :: PathSegment -> sem (Captured a sem)
   default capturePathSegment ::
-    (Captured a (Derived sem) ~ Captured a sem) =>
-    (FromDerived (Capturable a) sem) =>
+    Captured a (Derived sem) ~ Captured a sem =>
+    FromDerived (Capturable a) sem =>
     PathSegment ->
     sem (Captured a sem)
   capturePathSegment = liftDerived . capturePathSegment @a
@@ -154,10 +155,10 @@ newtype CapturedExtra a extra = CapturedExtra (Either (a, extra) a)
 -- instance Capturable sem => Capturable (Reader r sem)
 data instance Data (Capturable a) sem r where
   CapturePathSegment ::
-    (Capturable a sem) =>
+    Capturable a sem =>
     PathSegment ->
     Data (Capturable a) sem (Captured a sem)
-instance (Capturable a sem) => Derivable (Data (Capturable a) sem) where
+instance Capturable a sem => Derivable (Data (Capturable a) sem) where
   derive = \case
     CapturePathSegment n -> capturePathSegment @a n
 instance (Capturable a sem, Typeable a) => Capturable a (SomeData sem) where
@@ -168,7 +169,7 @@ instance (Capturable a sem, Typeable a) => Capturable a (SomeData sem) where
 class Fileable sem where
   type FileableConstraint sem :: Type -> Constraint
   static :: sem ()
-  dynamic :: (FileableConstraint sem a) => sem a
+  dynamic :: FileableConstraint sem a => sem a
 
 -- * Class 'Responsable'
 class Responsable a (ts :: [Type]) (m :: Type -> Type) sem where
@@ -177,6 +178,14 @@ class Responsable a (ts :: [Type]) (m :: Type -> Type) sem where
   -- response :: sem (Responsed a ts m end sem)
   response :: sem (Endpoint sem (Response ts m a))
 
+coding ::
+  forall ts m sem.
+  Monad m =>
+  Voidable sem =>
+  Responsable () ts m sem =>
+  sem ()
+coding = void (Endpoint (Response (return @m ()))) (response @() @ts)
+
 -- ** Type 'Response'
 newtype Response (ts :: [Type]) m a = Response {unResponse :: m a}
   deriving (Functor, Applicative, Monad)
@@ -188,6 +197,6 @@ class Optionable a sem where
   optional :: sem a -> sem (Maybe a)
   optional = liftDerived1 optional
   default optional ::
-    (FromDerived1 (Optionable a) sem) =>
+    FromDerived1 (Optionable a) sem =>
     sem a ->
     sem (Maybe a)