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