src/Literate/Web/Syntaxes.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 -- For IfSemantic
   3 {-# LANGUAGE ConstraintKinds #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE PatternSynonyms #-}
   6 {-# LANGUAGE RankNTypes #-}
   7 {-# LANGUAGE UndecidableInstances #-}
   8 {-# OPTIONS_GHC -Wno-orphans #-}
   9
  10 module Literate.Web.Syntaxes (
  11   module Literate.Web.Syntaxes,
  12   ProductFunctor (..),
  13   SumFunctor (..),
  14   Repeatable (..),
  15   Optionable (..),
  16   Dataable (..),
  17   Inferable (..),
  18   IsoFunctor (..),
  19   pattern (:!:),
  20   Endpoint (..),
  21   ToFEndpoint,
  22   ToFable,
  23   type (-->),
  24 ) where
  25
  26 import Control.Applicative (Applicative)
  27 import Control.Monad (Monad (..))
  28 import Control.Monad.Classes qualified as MC
  29 import Control.Monad.Trans.Class as MT
  30 import Data.Bool (Bool (..))
  31 import Data.ByteString.Lazy qualified as BSL
  32 import Data.Either (Either (..))
  33 import Data.Function ((.))
  34 import Data.Functor (Functor)
  35 import Data.Kind (Constraint, Type)
  36 import Data.Maybe (Maybe)
  37 import Data.Typeable (Typeable)
  38 import Literate.Web.Types.URL
  39 import Symantic.Semantics (Reader (..))
  40 import Symantic.Semantics.Data (Data, SomeData (..))
  41 import Symantic.Syntaxes (
  42   Dataable (..),
  43   Endpoint (..),
  44   Inferable (..),
  45   IsoFunctor (..),
  46   ProductFunctor (..),
  47   Repeatable (..),
  48   SumFunctor (..),
  49   ToFEndpoint,
  50   ToFable,
  51   Voidable (..),
  52   dataType,
  53   pattern (:!:),
  54   type (-->),
  55  )
  56 import Symantic.Syntaxes.Derive hiding (Semantic)
  57 import System.FilePath (FilePath)
  58
  59 -- deriving instance PathSegmentable sem => PathSegmentable (Reflector r sem)
  60 -- deriving instance Endable sem => Endable (Reflector r sem)
  61 -- deriving instance Capturable sem => Capturable (Reflector r sem)
  62
  63 -- * Class 'PathSegmentable'
  64
  65 -- | Syntax (final algebra) for expressing URL paths.
  66 class PathSegmentable sem where
  67   -- choosePathSegments :: Set [PathSegment] -> sem [PathSegment]
  68   -- default choosePathSegments :: FromDerived PathSegmentable sem => Set [PathSegment] -> sem [PathSegment]
  69   -- choosePathSegments = liftDerived . choosePathSegments
  70   -- pathSegment :: PathSegment -> sem a -> sem a
  71
  72   pathSegment :: PathSegment -> sem ()
  73   default pathSegment :: FromDerived PathSegmentable sem => PathSegment -> sem ()
  74   -- default pathSegment :: IsoFunctor sem => PathSegment -> sem ()
  75   -- pathSegment s = Iso (const ()) (const s) <%> pathSegments (Set.singleton s)
  76   pathSegment = liftDerived . pathSegment
  77
  78 -- pathSegments :: Set PathSegment -> sem PathSegment
  79 -- default pathSegments :: FromDerived PathSegmentable sem => Set PathSegment -> sem PathSegment
  80 -- pathSegments = liftDerived . pathSegments
  81
  82 -- default pathSegments :: IsoFunctor sem => Set PathSegment -> sem PathSegment
  83 -- pathSegments s = Iso List.head pure <%> choosePathSegments (Set.mapMonotonic pure s)
  84
  85 instance (PathSegmentable sem, IsoFunctor sem) => PathSegmentable (Reader r sem)
  86
  87 -- | Pattern-matchable encoding (initial algebra) of 'PathSegmentable'.
  88 data instance Data PathSegmentable sem a where
  89   PathSegment :: PathSegment -> Data PathSegmentable sem ()
  90
  91 -- PathSegments :: Set PathSegment -> Data PathSegmentable sem PathSegment
  92
  93 -- ChoosePathSegments :: Set [PathSegment] -> Data PathSegmentable sem [PathSegment]
  94
  95 -- | Initial to final algebra.
  96 instance PathSegmentable sem => Derivable (Data PathSegmentable sem) where
  97   derive = \case
  98     PathSegment x -> pathSegment x
  99
 100 -- PathSegments x -> pathSegments x
 101
 102 -- ChoosePathSegments x -> choosePathSegments x
 103
 104 -- | Final to initial algebra.
 105 instance PathSegmentable sem => PathSegmentable (SomeData sem) where
 106   pathSegment = SomeData . PathSegment
 107
 108 -- pathSegments = SomeData . PathSegments
 109
 110 -- choosePathSegments = SomeData . ChoosePathSegments
 111
 112 -- | Convenient alias for an @index.html@ page.
 113 index :: PathSegmentable sem => sem ()
 114 index = pathSegment "index.html"
 115
 116 -- | Convenient alias for prefixing with a 'pathSegment'.
 117 (</>) ::
 118   ProductFunctor sem =>
 119   PathSegmentable sem =>
 120   PathSegment ->
 121   sem a ->
 122   sem a
 123 (</>) n = (pathSegment n .>)
 124
 125 infixr 4 </>
 126
 127 -- * Class 'Copyable'
 128 class Copyable sem where
 129   copy :: FilePath -> sem ()
 130
 131 -- * Class 'Encodable'
 132 class Encodable fmt a where
 133   encode :: a -> BSL.ByteString
 134
 135 -- * Class 'Capturable'
 136 class Capturable a sem where
 137   type Captured a sem :: Type
 138   type Captured a sem = a
 139   capturePathSegment :: PathSegment -> sem (Captured a sem)
 140   default capturePathSegment ::
 141     Captured a (Derived sem) ~ Captured a sem =>
 142     FromDerived (Capturable a) sem =>
 143     PathSegment ->
 144     sem (Captured a sem)
 145   capturePathSegment = liftDerived . capturePathSegment @a
 146
 147 -- | @('CapturedExtra' a extra)@ is useful to add @(extra)@ data
 148 -- to a 'Captured' value, eg. when using the 'Compiler' semantic,
 149 -- to add the content of a page whose name was captured
 150 -- directly available when iterating all the pages,
 151 -- hence avoiding to lookup that content as would be done
 152 -- when using the 'Server' semantic.
 153 newtype CapturedExtra a extra = CapturedExtra (Either (a, extra) a)
 154
 155 -- instance Capturable sem => Capturable (Reader r sem)
 156 data instance Data (Capturable a) sem r where
 157   CapturePathSegment ::
 158     Capturable a sem =>
 159     PathSegment ->
 160     Data (Capturable a) sem (Captured a sem)
 161 instance Capturable a sem => Derivable (Data (Capturable a) sem) where
 162   derive = \case
 163     CapturePathSegment n -> capturePathSegment @a n
 164 instance (Capturable a sem, Typeable a) => Capturable a (SomeData sem) where
 165   type Captured a (SomeData sem) = Captured a sem
 166   capturePathSegment = SomeData . CapturePathSegment @a
 167
 168 -- * Class 'Fileable'
 169 class Fileable sem where
 170   type FileableConstraint sem :: Type -> Constraint
 171   static :: sem ()
 172   dynamic :: FileableConstraint sem a => sem a
 173
 174 -- * Class 'Responsable'
 175 class Responsable a (ts :: [Type]) (m :: Type -> Type) sem where
 176   -- type Responsed a (ts::[Type]) (m::Type -> Type) end sem
 177   -- type Responsed a ts m end sem = Endpoint end (Response ts m a)
 178   -- response :: sem (Responsed a ts m end sem)
 179   response :: sem (Endpoint sem (Response ts m a))
 180
 181 coding ::
 182   forall ts m sem.
 183   Monad m =>
 184   Voidable sem =>
 185   Responsable () ts m sem =>
 186   sem ()
 187 coding = void (Endpoint (Response (return @m ()))) (response @() @ts)
 188
 189 -- ** Type 'Response'
 190 newtype Response (ts :: [Type]) m a = Response {unResponse :: m a}
 191   deriving (Functor, Applicative, Monad)
 192 type instance MC.CanDo (Response ts m) eff = 'False
 193 instance MT.MonadTrans (Response ts) where lift = Response
 194
 195 -- ** Class 'Optionable'
 196 class Optionable a sem where
 197   optional :: sem a -> sem (Maybe a)
 198   optional = liftDerived1 optional
 199   default optional ::
 200     FromDerived1 (Optionable a) sem =>
 201     sem a ->
 202     sem (Maybe a)