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   dataType,
  20   pattern (:!:),
  21 ) where
  22
  23 import Control.Applicative (Applicative)
  24 import Control.Monad (Monad)
  25 import Control.Monad.Classes qualified as MC
  26 import Control.Monad.Trans.Class as MT
  27 import Data.Either (Either)
  28 import Data.Bool (Bool (..))
  29 import Data.ByteString.Lazy qualified as BSL
  30 import Data.Function ((.))
  31 import Data.Functor as Functor
  32 import Data.Maybe (Maybe)
  33 import Data.Kind (Constraint, Type)
  34 import Data.Typeable (Typeable)
  35 import Literate.Web.Types.URL
  36 import Literate.Web.Types.MIME
  37 import Symantic.Semantics (Reader (..))
  38 import Symantic qualified as Sym
  39 import GHC.Generics (Generic)
  40 import Symantic.Semantics.ToFer (
  41   ToFer (..),
  42  )
  43 import Symantic.Syntaxes (
  44   Dataable (..),
  45   Endpoint,
  46   Inferable (..),
  47   IsToF,
  48   IsoFunctor (..),
  49   ProductFunctor (..),
  50   Repeatable (..),
  51   SumFunctor (..),
  52   dataType,
  53   pattern (:!:),
  54  )
  55 import Symantic.Syntaxes.Data (Data, SomeData (..))
  56 import Symantic.Syntaxes.Derive
  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 instance (PathSegmentable sem, Functor sem) => PathSegmentable (ToFer sem) where
  79   pathSegment s =
  80     ToFer
  81       { tuplesOfFunctions = (Functor.<$ eot)
  82       , eithersOfTuples = eot
  83       }
  84     where
  85       eot = pathSegment s
  86
  87 -- pathSegments :: Set PathSegment -> sem PathSegment
  88 -- default pathSegments :: FromDerived PathSegmentable sem => Set PathSegment -> sem PathSegment
  89 -- pathSegments = liftDerived . pathSegments
  90
  91 -- default pathSegments :: IsoFunctor sem => Set PathSegment -> sem PathSegment
  92 -- pathSegments s = Iso List.head pure <%> choosePathSegments (Set.mapMonotonic pure s)
  93
  94 instance (PathSegmentable sem, IsoFunctor sem) => PathSegmentable (Reader r sem)
  95
  96 -- | Pattern-matchable encoding (initial algebra) of 'PathSegmentable'.
  97 data instance Data PathSegmentable sem a where
  98   PathSegment :: PathSegment -> Data PathSegmentable sem ()
  99
 100 -- PathSegments :: Set PathSegment -> Data PathSegmentable sem PathSegment
 101
 102 -- ChoosePathSegments :: Set [PathSegment] -> Data PathSegmentable sem [PathSegment]
 103
 104 -- | Initial to final algebra.
 105 instance PathSegmentable sem => Derivable (Data PathSegmentable sem) where
 106   derive = \case
 107     PathSegment x -> pathSegment x
 108
 109 -- PathSegments x -> pathSegments x
 110
 111 -- ChoosePathSegments x -> choosePathSegments x
 112
 113 -- | Final to initial algebra.
 114 instance PathSegmentable sem => PathSegmentable (SomeData sem) where
 115   pathSegment = SomeData . PathSegment
 116
 117 -- pathSegments = SomeData . PathSegments
 118
 119 --choosePathSegments = SomeData . ChoosePathSegments
 120
 121 -- | Convenient alias for an @index.html@ page.
 122 index :: PathSegmentable sem => sem ()
 123 index = pathSegment "index.html"
 124
 125 -- | Convenient alias for prefixing with a 'pathSegment'.
 126 (</>) ::
 127   ProductFunctor sem =>
 128   PathSegmentable sem =>
 129   PathSegment ->
 130   sem a ->
 131   sem a
 132 (</>) n = (pathSegment n .>)
 133
 134 infixr 4 </>
 135
 136 -- * Class 'Copyable'
 137 class Copyable sem where
 138   copy :: FilePath -> sem ()
 139
 140 -- * Class 'Encodable'
 141 class Encodable fmt a where
 142   encode :: a -> BSL.ByteString
 143
 144 -- * Class 'Capturable'
 145 class Capturable a sem where
 146   type Captured a sem :: Type
 147   type Captured a sem = a
 148   capturePathSegment :: PathSegment -> sem (Captured a sem)
 149   default capturePathSegment ::
 150     Captured a (Derived sem) ~ Captured a sem =>
 151     FromDerived (Capturable a) sem =>
 152     PathSegment ->
 153     sem (Captured a sem)
 154   capturePathSegment = liftDerived . capturePathSegment @a
 155
 156 -- | The @('IsToF' a ~ 'False)@ constraint
 157 -- disables capturing tuples or functions.
 158 instance
 159   ( Capturable a sem
 160   , IsToF (Captured a sem) ~ 'False
 161   , Functor sem
 162   ) => Capturable a (ToFer sem) where
 163   type Captured a (ToFer sem) = Captured a sem
 164   capturePathSegment _n =
 165     ToFer
 166       { tuplesOfFunctions = \next -> next <$> capturePathSegment @a _n
 167       , eithersOfTuples = capturePathSegment @a _n
 168       }
 169
 170 -- | @('CapturedExtra' a extra)@ is useful to add @(extra)@ data
 171 -- to a 'Captured' value, eg. when using the 'Compiler' semantic,
 172 -- to add the content of a page whose name was captured
 173 -- directly available when iterating all the pages,
 174 -- hence avoiding to lookup that content as would be done
 175 -- when using the 'Server' semantic.
 176 newtype CapturedExtra a extra = CapturedExtra (Either (a, extra) a)
 177
 178 --instance Capturable sem => Capturable (Reader r sem)
 179 data instance Data (Capturable a) sem r where
 180   CapturePathSegment ::
 181     Capturable a sem =>
 182     PathSegment ->
 183     Data (Capturable a) sem (Captured a sem)
 184 instance Capturable a sem => Derivable (Data (Capturable a) sem) where
 185   derive = \case
 186     CapturePathSegment n -> capturePathSegment @a n
 187 instance (Capturable a sem, Typeable a) => Capturable a (SomeData sem) where
 188   type Captured a (SomeData sem) = Captured a sem
 189   capturePathSegment = SomeData . CapturePathSegment @a
 190
 191 -- * Class 'Fileable'
 192 class Fileable sem where
 193   type FileableConstraint sem :: Type -> Constraint
 194   static :: sem ()
 195   dynamic :: FileableConstraint sem a => sem a
 196
 197 -- * Class 'Responsable'
 198 class Responsable a (ts::[Type]) (m::Type -> Type) end sem where
 199   --type Responsed a (ts::[Type]) (m::Type -> Type) end sem
 200   --type Responsed a ts m end sem = Endpoint end (Response ts m a)
 201   --response :: sem (Responsed a ts m end sem)
 202   response :: sem (Endpoint end (Response ts m a))
 203 class Responsable2 a (ts::[Type]) sem where
 204   response2 :: MimeTypes ts (MimeEncodable a) => sem a -> sem a
 205
 206 -- ** Type 'Response'
 207 newtype Response (ts :: [Type]) m a = Response {unResponse :: m a}
 208   deriving (Functor, Applicative, Monad)
 209 type instance MC.CanDo (Response ts m) eff = 'False
 210 instance MT.MonadTrans (Response ts) where lift = Response
 211
 212 class Generic a => Dataable__ a sem where
 213   data__ :: sem (Sym.EoT (Sym.ADT a)) -> sem a
 214
 215 -- ** Class 'Optionable'
 216 class Optionable a sem where
 217   optional :: sem a -> sem (Maybe a)
 218   optional = liftDerived1 optional
 219   default optional ::
 220     FromDerived1 (Optionable a) sem =>
 221     sem a ->
 222     sem (Maybe a)