From: Julien Moutinho <julm+literate-web@sourcephile.fr>
Date: Thu, 28 Nov 2024 01:06:58 +0000 (+0100)
Subject: fix(addresser): support extensions
X-Git-Url: https://git.sourcephile.fr/haskell/literate-web.git/commitdiff_plain

fix(addresser): support extensions
---

diff --git a/src/Literate/Web/Semantics/Addresser.hs b/src/Literate/Web/Semantics/Addresser.hs
index 7876b2e..19ea728 100644
--- a/src/Literate/Web/Semantics/Addresser.hs
+++ b/src/Literate/Web/Semantics/Addresser.hs
@@ -6,14 +6,20 @@
 module Literate.Web.Semantics.Addresser where
 
 import Data.Bool
+import Data.Eq (Eq)
 import Data.Function (id, ($), (.))
+import Data.Functor ((<$>))
+import Data.List qualified as List
 import Data.Maybe (Maybe (..))
 import Data.Monoid (Monoid (..))
+import Data.Ord (Ord)
 import Data.Semigroup (Semigroup (..))
+import Data.Text qualified as Text
 import GHC.Generics (Generic)
 import Literate.Web.Syntaxes
 import Literate.Web.Types.URL
 import Symantic qualified as Sym
+import System.FilePath qualified as Sys
 import Text.Show (Show (..))
 
 -- * Type 'Addresser'
@@ -29,15 +35,15 @@ type instance ToFEndpoint Addresser a next = next
 address :: Addresser a -> a --> Address
 address router = unAddresser router id
 
-instance PathSegmentable (Addresser) where
-  pathSegment s = Addresser \f -> f Address{addressPath = [s]}
+instance PathSegmentable Addresser where
+  pathSegment s = Addresser \f -> f Address{addressSegs = [s], addressExts = []}
 
 instance Sym.SumFunctor Addresser where
   a <+> b = Addresser \n -> (unAddresser a n, unAddresser b n)
 instance Sym.ProductFunctor Addresser where
-  a <.> b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (bA <> aA)
-  a <. b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (bA <> aA)
-  a .> b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (bA <> aA)
+  a <.> b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (aA <> bA)
+  a <. b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (aA <> bA)
+  a .> b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (aA <> bA)
 instance
   ( Generic a
   , Sym.EoTOfRep a
@@ -50,20 +56,31 @@ instance
   where
   -- dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
   dataType a = Addresser (\a2n -> Sym.funOftof (unAddresser a a2n) . Sym.eotOfadt)
-instance (Sym.IsToF a ~ 'False) => Optionable a Addresser where
+instance Sym.IsToF a ~ 'False => Optionable a Addresser where
   optional aA = Addresser \k -> \case
     Nothing -> k mempty
     Just a -> unAddresser aA k a
 
-instance (end ~ Address) => Responsable a ts m (Addresser) where
+instance end ~ Address => Responsable a ts m (Addresser) where
   response = Addresser ($ mempty)
 
 -- ** Type 'Address'
-newtype Address = Address
-  { addressPath :: [PathSegment]
+data Address = Address
+  { addressSegs :: [PathSegment]
+  , addressExts :: [PathSegment]
   }
-  deriving (Show)
-instance Semigroup (Address) where
-  Address a <> Address b = Address (a <> b)
-instance Monoid (Address) where
-  mempty = Address []
+  deriving (Eq, Ord, Show)
+instance Semigroup Address where
+  x <> y =
+    Address
+      { addressSegs = addressSegs x <> addressSegs y
+      , addressExts = addressExts x <> addressExts y
+      }
+instance Monoid Address where
+  mempty = Address{addressSegs = [], addressExts = []}
+
+addressFile :: Address -> Sys.FilePath
+addressFile addr =
+  List.intercalate "." $
+    encodePath (addressSegs addr)
+      : (Text.unpack . encodePathSegment <$> addressExts addr)
diff --git a/tests/Examples/Ex03.hs b/tests/Examples/Ex03.hs
index 11006cd..d999097 100644
--- a/tests/Examples/Ex03.hs
+++ b/tests/Examples/Ex03.hs
@@ -95,7 +95,8 @@ instance MC.MonadReader Model m => Capturable Tag (Compiler m) where
 
 instance Capturable Tag Addresser where
   -- FIXME: check given tag exists?
-  capturePathSegment _n = Addresser \k t -> k (Address [unTag t])
+  capturePathSegment _n = Addresser \k t ->
+    k Address{addressSegs = [unTag t], addressExts = []}
 
 -- * Type 'Model'
 data Model = Model