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 Control.Arrow ((>>>))
   9 import Data.Bool
  10 import Data.Eq (Eq)
  11 import Data.Function (id, ($), (&), (.))
  12 import Data.Functor ((<&>))
  13 import Data.List qualified as List
  14 import Data.Maybe (Maybe (..))
  15 import Data.Monoid (Monoid (..))
  16 import Data.Ord (Ord)
  17 import Data.Semigroup (Semigroup (..))
  18 import Data.Text qualified as Text
  19 import GHC.Generics (Generic)
  20 import Literate.Web.Syntaxes
  21 import Literate.Web.Types.URI
  22 import Symantic qualified as Sym
  23 import System.FilePath qualified as Sys
  24 import Text.Show (Show (..))
  25
  26 -- * Type 'Addresser'
  27
  28 -- Interpreter building 'Address'.
  29 data Addresser a = Addresser
  30   { unAddresser :: forall next. (Address -> next) -> a --> next
  31   }
  32
  33 -- | Nothing is needed at the 'Endpoint' for building an 'Address'.
  34 type instance ToFEndpoint Addresser a next = next
  35
  36 address :: Addresser a -> a --> Address
  37 address router = unAddresser router id
  38
  39 instance PathSegmentable Addresser where
  40   pathSegment s = Addresser \f -> f Address{addressSegs = [s], addressExts = []}
  41
  42 instance Sym.SumFunctor Addresser where
  43   a <+> b = Addresser \n -> (unAddresser a n, unAddresser b n)
  44 instance Sym.ProductFunctor Addresser where
  45   a <.> b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (aA <> bA)
  46   a <. b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (aA <> bA)
  47   a .> b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (aA <> bA)
  48 instance
  49   ( Generic a
  50   , Sym.EoTOfRep a
  51   , sem ~ Addresser
  52   , Sym.IsToF a ~ 'False
  53   , e ~ Sym.EoT (Sym.ADT a)
  54   , Sym.ToFable e
  55   ) =>
  56   Dataable a Addresser
  57   where
  58   -- dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
  59   dataType a = Addresser (\a2n -> Sym.funOftof (unAddresser a a2n) . Sym.eotOfadt)
  60 instance Sym.IsToF a ~ 'False => Optionable a Addresser where
  61   optional aA = Addresser \k -> \case
  62     Nothing -> k mempty
  63     Just a -> unAddresser aA k a
  64
  65 instance end ~ Address => Responsable a ts m (Addresser) where
  66   response = Addresser ($ mempty)
  67
  68 -- ** Type 'Address'
  69 data Address = Address
  70   { addressSegs :: [PathSegment]
  71   , addressExts :: [PathSegment]
  72   }
  73   deriving (Eq, Ord, Show)
  74 instance Semigroup Address where
  75   x <> y =
  76     Address
  77       { addressSegs = addressSegs x <> addressSegs y
  78       , addressExts = addressExts x <> addressExts y
  79       }
  80 instance Monoid Address where
  81   mempty = Address{addressSegs = [], addressExts = []}
  82
  83 addressFile :: Address -> Sys.FilePath
  84 addressFile addr =
  85   List.intercalate "." $
  86     (addressSegs addr & pathToFilePath)
  87       : (addressExts addr <&> (unPathSegment >>> Text.unpack))