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