src/Literate/Web/Semantics/Addresser.hs

   1 -- For Addresser
   2 {-# LANGUAGE DeriveFunctor #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4 {-# LANGUAGE PartialTypeSignatures #-}
   5 {-# LANGUAGE RankNTypes #-}
   6 {-# LANGUAGE UndecidableInstances #-}
   7 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   8 {-# LANGUAGE InstanceSigs #-}
   9 {-# LANGUAGE AllowAmbiguousTypes #-}
  10 {-# LANGUAGE ConstraintKinds #-}
  11
  12 module Literate.Web.Semantics.Addresser where
  13
  14 import Control.Applicative (Applicative (..))
  15 import Control.Monad (Monad (..), forM, forM_, join, sequence, (>=>), (>>=))
  16 import Control.Monad.Classes qualified as MC
  17 import Control.Monad.Trans.Class qualified as MT
  18 import Control.Monad.Trans.Reader qualified as MT
  19 import Control.Monad.Trans.State qualified as MT
  20 import Control.Monad.Trans.Writer qualified as MT
  21 import Type.Reflection ((:~:) (..))
  22 import Data.Bool
  23 import Data.ByteString.Lazy qualified as BSL
  24 import Data.Either (Either (..))
  25 import Data.Eq (Eq (..))
  26 import Data.Foldable (toList)
  27 import Data.Monoid (Monoid(..))
  28 import Data.Function (const, id, ($), (.))
  29 import Data.Functor (Functor (..), (<$>))
  30 import Data.Kind (Constraint, Type)
  31 import Data.List qualified as List
  32 import Data.Maybe (Maybe (..))
  33 import Data.Ord (Ord (..))
  34 import Data.Proxy (Proxy (..))
  35 import Data.Semigroup (Semigroup (..))
  36 import Data.String (fromString)
  37 import Data.Text (Text)
  38 import Data.Text qualified as Text
  39 import Data.Tuple (curry)
  40 import GHC.Generics (Generic)
  41 import GHC.Stack (HasCallStack)
  42 import Literate.Web.Syntaxes
  43 import Literate.Web.Types.MIME
  44 import Literate.Web.Types.URL
  45 import Symantic qualified as Sym
  46 import System.Directory qualified as Sys
  47 import System.FilePath qualified as Sys
  48 import System.FilePattern.Directory qualified as Sys
  49 import System.IO qualified as Sys
  50 import Text.Show (Show (..))
  51
  52 -- * Type 'Addresser'
  53 data Addresser a = Addresser
  54   { unAddresser :: forall next. (Address -> next) -> a --> next
  55   }
  56
  57 -- * Type family '(-->)'
  58 -- | Convenient alias for a Tuples of Functions transformation
  59 type (-->) a next = ToFIf (Sym.IsToF a) a next
  60 infixr 0 -->
  61 type family ToFIf t a next :: Type where
  62 -- For '<.>': curry.
  63   ToFIf 'True (a, b) next = a --> b --> next
  64 -- For '<+>', request both branches.
  65   ToFIf 'True (Either l r) next = (l --> next, r --> next)
  66 -- Useless to ask '()' as argument.
  67   ToFIf 'True () next = next
  68 -- Enable a different return value for each function.
  69   ToFIf 'True (Sym.Endpoint end a) next = next
  70 -- Everything else becomes a new argument.
  71   ToFIf 'False a next = a -> next
  72
  73 -- ** Class 'UnToF'
  74 type UnToF a = UnToFIf (Sym.IsToF a) a
  75 class UnToFIf (t :: Bool) a where
  76   unToF :: ToFIf t a next -> a -> next
  77 instance UnToFIf 'True () where
  78   unToF = const
  79 instance (UnToF a, UnToF b) => UnToFIf 'True (a, b) where
  80   unToF hab (a, b) = (unToF @(Sym.IsToF b) (unToF @(Sym.IsToF a) hab a)) b
  81 instance (UnToF a, UnToF b) => UnToFIf 'True (Either a b) where
  82   unToF (ha, hb) = \case
  83     Left a -> unToF @(Sym.IsToF a) ha a
  84     Right b -> unToF @(Sym.IsToF b) hb b
  85 instance UnToFIf 'False a where
  86   unToF = id
  87
  88
  89 address :: Addresser a -> a --> Address
  90 address router = unAddresser router id
  91
  92 instance PathSegmentable (Addresser) where
  93   pathSegment s = Addresser \f -> f Address {addressPath = [s]}
  94
  95 instance Sym.SumFunctor Addresser where
  96   a <+> b = Addresser \n -> (unAddresser a n, unAddresser b n)
  97 instance Sym.ProductFunctor Addresser where
  98   a <.> b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (bA <> aA)
  99   a <. b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (bA <> aA)
 100   a .> b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (bA <> aA)
 101
 102 instance
 103   ( Generic a
 104   , Sym.EoTOfRep a
 105   , sem ~ Addresser
 106   , Sym.IsToF a ~ 'False
 107   , e ~ Sym.EoT (Sym.ADT a)
 108   , UnToF e
 109   ) => Dataable__ a Addresser where
 110   data__ :: sem (Sym.EoT (Sym.ADT a)) -> sem a
 111   data__ a = Addresser (\a2n -> unToF @(Sym.IsToF e) @e (unAddresser a a2n) . Sym.eotOfadt)
 112
 113 instance end ~ Address => Responsable a ts m end (Addresser) where
 114   response = Addresser ($ mempty)
 115
 116 -- ** Type 'Address'
 117 newtype Address = Address
 118   { addressPath :: [PathSegment]
 119   }
 120   deriving (Show)
 121 instance Semigroup (Address) where
 122   Address a <> Address b = Address (a <> b)
 123 instance Monoid (Address) where
 124   mempty = Address []