src/Literate/Web/Semantics/Addresser.hs

   1 -- For Addresser
   2 {-# LANGUAGE RankNTypes #-}
   3 -- For Dataable
   4 {-# LANGUAGE UndecidableInstances #-}
   5
   6 module Literate.Web.Semantics.Addresser where
   7
   8 import Data.Bool
   9 import Data.Function (id, ($), (.))
  10 import Data.Maybe (Maybe (..))
  11 import Data.Monoid (Monoid (..))
  12 import Data.Semigroup (Semigroup (..))
  13 import GHC.Generics (Generic)
  14 import Literate.Web.Syntaxes
  15 import Literate.Web.Types.URL
  16 import Symantic qualified as Sym
  17 import Text.Show (Show (..))
  18
  19 -- * Type 'Addresser'
  20
  21 -- Interpreter building 'Address'.
  22 data Addresser a = Addresser
  23   { unAddresser :: forall next. (Address -> next) -> a --> next
  24   }
  25
  26 -- | Nothing is needed at the 'Endpoint' for building an 'Address'.
  27 type instance ToFEndpoint Addresser a next = next
  28
  29 address :: Addresser a -> a --> Address
  30 address router = unAddresser router id
  31
  32 instance PathSegmentable (Addresser) where
  33   pathSegment s = Addresser \f -> f Address{addressPath = [s]}
  34
  35 instance Sym.SumFunctor Addresser where
  36   a <+> b = Addresser \n -> (unAddresser a n, unAddresser b n)
  37 instance Sym.ProductFunctor Addresser where
  38   a <.> b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (bA <> aA)
  39   a <. b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (bA <> aA)
  40   a .> b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (bA <> aA)
  41 instance
  42   ( Generic a
  43   , Sym.EoTOfRep a
  44   , sem ~ Addresser
  45   , Sym.IsToF a ~ 'False
  46   , e ~ Sym.EoT (Sym.ADT a)
  47   , Sym.ToFable e
  48   ) =>
  49   Dataable a Addresser
  50   where
  51   -- dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
  52   dataType a = Addresser (\a2n -> Sym.funOftof (unAddresser a a2n) . Sym.eotOfadt)
  53 instance (Sym.IsToF a ~ 'False) => Optionable a Addresser where
  54   optional aA = Addresser \k -> \case
  55     Nothing -> k mempty
  56     Just a -> unAddresser aA k a
  57
  58 instance (end ~ Address) => Responsable a ts m (Addresser) where
  59   response = Addresser ($ mempty)
  60
  61 -- ** Type 'Address'
  62 newtype Address = Address
  63   { addressPath :: [PathSegment]
  64   }
  65   deriving (Show)
  66 instance Semigroup (Address) where
  67   Address a <> Address b = Address (a <> b)
  68 instance Monoid (Address) where
  69   mempty = Address []