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 as 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   dataType,
  52   pattern (:!:),
  53   type (-->),
  54  )
  55 import Symantic.Syntaxes.Derive hiding (Semantic)
  56 import System.FilePath (FilePath)
  57
  58 -- deriving instance PathSegmentable sem => PathSegmentable (Reflector r sem)
  59 -- deriving instance Endable sem => Endable (Reflector r sem)
  60 -- deriving instance Capturable sem => Capturable (Reflector r sem)
  61
  62 -- * Class 'PathSegmentable'
  63
  64 -- | Syntax (final algebra) for expressing URL paths.
  65 class PathSegmentable sem where
  66   -- choosePathSegments :: Set [PathSegment] -> sem [PathSegment]
  67   -- default choosePathSegments :: FromDerived PathSegmentable sem => Set [PathSegment] -> sem [PathSegment]
  68   -- choosePathSegments = liftDerived . choosePathSegments
  69   -- pathSegment :: PathSegment -> sem a -> sem a
  70
  71   pathSegment :: PathSegment -> sem ()
  72   default pathSegment :: (FromDerived PathSegmentable sem) => PathSegment -> sem ()
  73   -- default pathSegment :: IsoFunctor sem => PathSegment -> sem ()
  74   -- pathSegment s = Iso (const ()) (const s) <%> pathSegments (Set.singleton s)
  75   pathSegment = liftDerived . pathSegment
  76
  77 -- pathSegments :: Set PathSegment -> sem PathSegment
  78 -- default pathSegments :: FromDerived PathSegmentable sem => Set PathSegment -> sem PathSegment
  79 -- pathSegments = liftDerived . pathSegments
  80
  81 -- default pathSegments :: IsoFunctor sem => Set PathSegment -> sem PathSegment
  82 -- pathSegments s = Iso List.head pure <%> choosePathSegments (Set.mapMonotonic pure s)
  83
  84 instance (PathSegmentable sem, IsoFunctor sem) => PathSegmentable (Reader r sem)
  85
  86 -- | Pattern-matchable encoding (initial algebra) of 'PathSegmentable'.
  87 data instance Data PathSegmentable sem a where
  88   PathSegment :: PathSegment -> Data PathSegmentable sem ()
  89
  90 -- PathSegments :: Set PathSegment -> Data PathSegmentable sem PathSegment
  91
  92 -- ChoosePathSegments :: Set [PathSegment] -> Data PathSegmentable sem [PathSegment]
  93
  94 -- | Initial to final algebra.
  95 instance (PathSegmentable sem) => Derivable (Data PathSegmentable sem) where
  96   derive = \case
  97     PathSegment x -> pathSegment x
  98
  99 -- PathSegments x -> pathSegments x
 100
 101 -- ChoosePathSegments x -> choosePathSegments x
 102
 103 -- | Final to initial algebra.
 104 instance (PathSegmentable sem) => PathSegmentable (SomeData sem) where
 105   pathSegment = SomeData . PathSegment
 106
 107 -- pathSegments = SomeData . PathSegments
 108
 109 -- choosePathSegments = SomeData . ChoosePathSegments
 110
 111 -- | Convenient alias for an @index.html@ page.
 112 index :: (PathSegmentable sem) => sem ()
 113 index = pathSegment "index.html"
 114
 115 -- | Convenient alias for prefixing with a 'pathSegment'.
 116 (</>) ::
 117   (ProductFunctor sem) =>
 118   (PathSegmentable sem) =>
 119   PathSegment ->
 120   sem a ->
 121   sem a
 122 (</>) n = (pathSegment n .>)
 123
 124 infixr 4 </>
 125
 126 -- * Class 'Copyable'
 127 class Copyable sem where
 128   copy :: FilePath -> sem ()
 129
 130 -- * Class 'Encodable'
 131 class Encodable fmt a where
 132   encode :: a -> BSL.ByteString
 133
 134 -- * Class 'Capturable'
 135 class Capturable a sem where
 136   type Captured a sem :: Type
 137   type Captured a sem = a
 138   capturePathSegment :: PathSegment -> sem (Captured a sem)
 139   default capturePathSegment ::
 140     (Captured a (Derived sem) ~ Captured a sem) =>
 141     (FromDerived (Capturable a) sem) =>
 142     PathSegment ->
 143     sem (Captured a sem)
 144   capturePathSegment = liftDerived . capturePathSegment @a
 145
 146 -- | @('CapturedExtra' a extra)@ is useful to add @(extra)@ data
 147 -- to a 'Captured' value, eg. when using the 'Compiler' semantic,
 148 -- to add the content of a page whose name was captured
 149 -- directly available when iterating all the pages,
 150 -- hence avoiding to lookup that content as would be done
 151 -- when using the 'Server' semantic.
 152 newtype CapturedExtra a extra = CapturedExtra (Either (a, extra) a)
 153
 154 -- instance Capturable sem => Capturable (Reader r sem)
 155 data instance Data (Capturable a) sem r where
 156   CapturePathSegment ::
 157     (Capturable a sem) =>
 158     PathSegment ->
 159     Data (Capturable a) sem (Captured a sem)
 160 instance (Capturable a sem) => Derivable (Data (Capturable a) sem) where
 161   derive = \case
 162     CapturePathSegment n -> capturePathSegment @a n
 163 instance (Capturable a sem, Typeable a) => Capturable a (SomeData sem) where
 164   type Captured a (SomeData sem) = Captured a sem
 165   capturePathSegment = SomeData . CapturePathSegment @a
 166
 167 -- * Class 'Fileable'
 168 class Fileable sem where
 169   type FileableConstraint sem :: Type -> Constraint
 170   static :: sem ()
 171   dynamic :: (FileableConstraint sem a) => sem a
 172
 173 -- * Class 'Responsable'
 174 class Responsable a (ts :: [Type]) (m :: Type -> Type) sem where
 175   -- type Responsed a (ts::[Type]) (m::Type -> Type) end sem
 176   -- type Responsed a ts m end sem = Endpoint end (Response ts m a)
 177   -- response :: sem (Responsed a ts m end sem)
 178   response :: sem (Endpoint sem (Response ts m a))
 179
 180 -- ** Type 'Response'
 181 newtype Response (ts :: [Type]) m a = Response {unResponse :: m a}
 182   deriving (Functor, Applicative, Monad)
 183 type instance MC.CanDo (Response ts m) eff = 'False
 184 instance MT.MonadTrans (Response ts) where lift = Response
 185
 186 -- ** Class 'Optionable'
 187 class Optionable a sem where
 188   optional :: sem a -> sem (Maybe a)
 189   optional = liftDerived1 optional
 190   default optional ::
 191     (FromDerived1 (Optionable a) sem) =>
 192     sem a ->
 193     sem (Maybe a)