t/repl tests/repl:
cabal repl $(CABAL_REPL_FLAGS) $(CABAL_TEST_FLAGS) --enable-tests $(project)-tests
t/ghcid tests/ghcid:
- ghcid $(GHCID_OPTIONS) --command 'cabal repl $(CABAL_REPL_FLAGS) $(CABAL_TEST_FLAGS) $(project):tests' --test ":main $(TEST_OPTIONS)"
+ ghcid $(GHCID_OPTIONS) --command 'cabal repl $(CABAL_REPL_FLAGS) $(project) $(addprefix --repl-options ,$(REPL_OPTIONS))' \
+ --run=':! ghcid $(GHCID_OPTIONS) --command "cabal repl $(CABAL_REPL_FLAGS) $(CABAL_TEST_FLAGS) $(project):tests" --test ":main $(TEST_OPTIONS)"'
.PHONY: benchmarks/time
bt benchmarks/time:
{
"nodes": {
+ "flake-compat": {
+ "flake": false,
+ "locked": {
+ "lastModified": 1673956053,
+ "narHash": "sha256-4gtG9iQuiKITOjNQQeQIpoIB6b16fm+504Ch3sNKLd8=",
+ "owner": "edolstra",
+ "repo": "flake-compat",
+ "rev": "35bb57c0c8d8b62bbfd284272c928ceb64ddbde9",
+ "type": "github"
+ },
+ "original": {
+ "owner": "edolstra",
+ "repo": "flake-compat",
+ "type": "github"
+ }
+ },
"flake-utils": {
+ "inputs": {
+ "systems": "systems"
+ },
"locked": {
- "lastModified": 1667077288,
- "narHash": "sha256-bdC8sFNDpT0HK74u9fUkpbf1MEzVYJ+ka7NXCdgBoaA=",
+ "lastModified": 1685518550,
+ "narHash": "sha256-o2d0KcvaXzTrPRIo0kOLV0/QXHhDQ5DTi+OxcjO8xqY=",
"owner": "numtide",
"repo": "flake-utils",
- "rev": "6ee9ebb6b1ee695d2cacc4faa053a7b9baa76817",
+ "rev": "a1720a10a6cfe8234c0e93907ffe81be440f4cef",
"type": "github"
},
"original": {
"type": "github"
}
},
+ "gitignore": {
+ "inputs": {
+ "nixpkgs": [
+ "pre-commit-hooks",
+ "nixpkgs"
+ ]
+ },
+ "locked": {
+ "lastModified": 1660459072,
+ "narHash": "sha256-8DFJjXG8zqoONA1vXtgeKXy68KdJL5UaXR8NtVMUbx8=",
+ "owner": "hercules-ci",
+ "repo": "gitignore.nix",
+ "rev": "a20de23b925fd8264fd7fad6454652e142fd7f73",
+ "type": "github"
+ },
+ "original": {
+ "owner": "hercules-ci",
+ "repo": "gitignore.nix",
+ "type": "github"
+ }
+ },
"nixpkgs": {
"locked": {
- "lastModified": 1686237827,
- "narHash": "sha256-fAZB+Zkcmc+qlauiFnIH9+2qgwM0NO/ru5pWEw3tDow=",
+ "lastModified": 1701389149,
+ "narHash": "sha256-rU1suTIEd5DGCaAXKW6yHoCfR1mnYjOXQFOaH7M23js=",
"owner": "NixOS",
"repo": "nixpkgs",
- "rev": "81ed90058a851eb73be835c770e062c6938c8a9e",
+ "rev": "5de0b32be6e85dc1a9404c75131316e4ffbc634c",
"type": "github"
},
"original": {
"type": "indirect"
}
},
+ "nixpkgs-stable": {
+ "locked": {
+ "lastModified": 1685801374,
+ "narHash": "sha256-otaSUoFEMM+LjBI1XL/xGB5ao6IwnZOXc47qhIgJe8U=",
+ "owner": "NixOS",
+ "repo": "nixpkgs",
+ "rev": "c37ca420157f4abc31e26f436c1145f8951ff373",
+ "type": "github"
+ },
+ "original": {
+ "owner": "NixOS",
+ "ref": "nixos-23.05",
+ "repo": "nixpkgs",
+ "type": "github"
+ }
+ },
"pre-commit-hooks": {
"inputs": {
+ "flake-compat": "flake-compat",
"flake-utils": "flake-utils",
+ "gitignore": "gitignore",
"nixpkgs": [
"nixpkgs"
- ]
+ ],
+ "nixpkgs-stable": "nixpkgs-stable"
},
"locked": {
- "lastModified": 1667992213,
- "narHash": "sha256-8Ens8ozllvlaFMCZBxg6S7oUyynYx2v7yleC5M0jJsE=",
+ "lastModified": 1692274144,
+ "narHash": "sha256-BxTQuRUANQ81u8DJznQyPmRsg63t4Yc+0kcyq6OLz8s=",
"owner": "cachix",
"repo": "pre-commit-hooks.nix",
- "rev": "ebcbfe09d2bd6d15f68de3a0ebb1e4dcb5cd324b",
+ "rev": "7e3517c03d46159fdbf8c0e5c97f82d5d4b0c8fa",
"type": "github"
},
"original": {
"pre-commit-hooks": "pre-commit-hooks_2"
},
"locked": {
- "lastModified": 1670713703,
- "narHash": "sha256-9U71SGSWzdFbrvCyo6IbNI8bhoM4Guz9nCGIqKJ7ttQ=",
+ "lastModified": 1693433189,
+ "narHash": "sha256-k4bWG1z6qvt7Cee15H0xwgVngBBQRqhFm4rp6JHn8Qg=",
"ref": "refs/heads/main",
- "rev": "6ce5a7f09fd4bc5bc7df3fd4bf797e8f1803cd88",
- "revCount": 81,
+ "rev": "9d93dbea0b1173304ac78b695371b3e14d0d8b9f",
+ "revCount": 100,
"type": "git",
"url": "git://git.sourcephile.fr/haskell/symantic-base"
},
"type": "git",
"url": "git://git.sourcephile.fr/haskell/symantic-base"
}
+ },
+ "systems": {
+ "locked": {
+ "lastModified": 1681028828,
+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+ "owner": "nix-systems",
+ "repo": "default",
+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-systems",
+ "repo": "default",
+ "type": "github"
+ }
}
},
"root": "root",
#nixpkgs.url = "github:NixOS/nixpkgs/cdead16a444a3e5de7bc9b0af8e198b11bb01804";
pre-commit-hooks.url = "github:cachix/pre-commit-hooks.nix";
pre-commit-hooks.inputs.nixpkgs.follows = "nixpkgs";
+ #symantic-base.url = "git+file:///home/julm/work/sourcephile/haskell/symantic-base";
symantic-base.url = "git://git.sourcephile.fr/haskell/symantic-base";
symantic-base.inputs.nixpkgs.follows = "nixpkgs";
};
${pkg} = doBenchmark (buildFromSdist (hfinal.callCabal2nix pkg ./. { }));
symantic-base = buildFromSdist (hfinal.callCabal2nix "symantic-base" inputs.symantic-base { });
#url-slug = buildFromSdist (hfinal.callCabal2nix "url-slug" inputs.url-slug { });
- doctest = dontCheck (doJailbreak (unmarkBroken hsuper.doctest));
- hspec-contrib = dontCheck (doJailbreak (unmarkBroken hsuper.hspec-contrib));
+ #doctest = dontCheck (doJailbreak (unmarkBroken hsuper.doctest));
+ #hspec-contrib = dontCheck (doJailbreak (unmarkBroken hsuper.hspec-contrib));
#relude = dontCheck (doJailbreak (unmarkBroken hsuper.relude));
- scotty = dontCheck (doJailbreak (unmarkBroken hsuper.scotty));
+ #scotty = dontCheck (doJailbreak (unmarkBroken hsuper.scotty));
+ mvc = dontCheck (doJailbreak (unmarkBroken hsuper.mvc));
+ mvc-updates = dontCheck (doJailbreak (unmarkBroken (
+ appendPatch hsuper.mvc-updates ./0001-mvc-updates-fix-L.pretraverseM.patch)));
});
});
in
common boilerplate
default-language: Haskell2010
default-extensions:
- NoImplicitPrelude
BlockArguments
DataKinds
DefaultSignatures
LambdaCase
MultiParamTypeClasses
NamedFieldPuns
+ NoImplicitPrelude
NumericUnderscores
OverloadedStrings
RecordWildCards
, directory >=1.3
, filepath >=1.4
, filepattern >=0.1
+ , ghc-prim
, hashable
, http-client >=0.6
, http-media >=0.7
, monad-classes
+ , mvc
+ , mvc-updates
, peano
, reflection
, symantic-base >=0.5
, warp
, websockets >=0.12
+-- , pipes
+-- , pipes-concurrency
+-- , pipes-group
+-- , pipes-parse
+-- , pipes-safe
library
import: boilerplate, library-deps
hs-source-dirs: src
exposed-modules:
Literate.Web
- Literate.Web.Semantics.Compiler
Literate.Web.Semantics.Addresser
+ Literate.Web.Semantics.Compiler
Literate.Web.Syntaxes
Literate.Web.Types.MIME
Literate.Web.Types.URL
+--Literate.Web.Semantics.Server
+--Literate.Web.Semantics.Client
+--Literate.Web.Decoder
+--Literate.Web.Encoder
+--Literate.Web.Generator
+--Literate.Web.MIME
+
library relactive
import: boilerplate, library-deps
hs-source-dirs: src
build-depends:
, async
, contravariant >=1.5
+ , monad-classes
, stm
exposed-modules:
Control.Reactive.TVar
Control.Reactive.Value
--- Literate.Web.Semantics.Server
--- Literate.Web.Semantics.Client
---Literate.Web.Decoder
---Literate.Web.Encoder
---Literate.Web.Generator
---Literate.Web.MIME
-
---Literate.Web.Decoder
test-suite literate-web-tests
-- library-deps is only to have ghcid reloaded on changes in src
import: boilerplate, library-deps
Paths_literate_web
Utils
- -- Examples.Ex02
- --HUnits
autogen-modules: Paths_literate_web
build-depends:
, base >=4.6 && <5
, relude >=1
, weigh
---, relactive
executable async
import: boilerplate, library-deps
hs-source-dirs: executables/async
-- For Addresser
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
+-- For Dataable
{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE ConstraintKinds #-}
module Literate.Web.Semantics.Addresser where
-import Control.Applicative (Applicative (..))
-import Control.Monad (Monad (..), forM, forM_, join, sequence, (>=>), (>>=))
-import Control.Monad.Classes qualified as MC
-import Control.Monad.Trans.Class qualified as MT
-import Control.Monad.Trans.Reader qualified as MT
-import Control.Monad.Trans.State qualified as MT
-import Control.Monad.Trans.Writer qualified as MT
-import Type.Reflection ((:~:) (..))
import Data.Bool
-import Data.ByteString.Lazy qualified as BSL
-import Data.Either (Either (..))
-import Data.Eq (Eq (..))
-import Data.Foldable (toList)
-import Data.Monoid (Monoid(..))
-import Data.Function (const, id, ($), (.))
-import Data.Functor (Functor (..), (<$>))
-import Data.Kind (Constraint, Type)
-import Data.List qualified as List
+import Data.Function (id, ($), (.))
import Data.Maybe (Maybe (..))
-import Data.Ord (Ord (..))
-import Data.Proxy (Proxy (..))
+import Data.Monoid (Monoid (..))
import Data.Semigroup (Semigroup (..))
-import Data.String (fromString)
-import Data.Text (Text)
-import Data.Text qualified as Text
-import Data.Tuple (curry)
import GHC.Generics (Generic)
-import GHC.Stack (HasCallStack)
import Literate.Web.Syntaxes
-import Literate.Web.Types.MIME
import Literate.Web.Types.URL
import Symantic qualified as Sym
-import System.Directory qualified as Sys
-import System.FilePath qualified as Sys
-import System.FilePattern.Directory qualified as Sys
-import System.IO qualified as Sys
import Text.Show (Show (..))
-- * Type 'Addresser'
+
+-- Interpreter building 'Address'.
data Addresser a = Addresser
{ unAddresser :: forall next. (Address -> next) -> a --> next
}
--- * Type family '(-->)'
--- | Convenient alias for a Tuples of Functions transformation
-type (-->) a next = ToFIf (Sym.IsToF a) a next
-infixr 0 -->
-type family ToFIf t a next :: Type where
--- For '<.>': curry.
- ToFIf 'True (a, b) next = a --> b --> next
--- For '<+>', request both branches.
- ToFIf 'True (Either l r) next = (l --> next, r --> next)
--- Useless to ask '()' as argument.
- ToFIf 'True () next = next
--- Enable a different return value for each function.
- ToFIf 'True (Sym.Endpoint end a) next = next
--- Everything else becomes a new argument.
- ToFIf 'False a next = a -> next
-
--- ** Class 'UnToF'
-type UnToF a = UnToFIf (Sym.IsToF a) a
-class UnToFIf (t :: Bool) a where
- unToF :: ToFIf t a next -> a -> next
-instance UnToFIf 'True () where
- unToF = const
-instance (UnToF a, UnToF b) => UnToFIf 'True (a, b) where
- unToF hab (a, b) = (unToF @(Sym.IsToF b) (unToF @(Sym.IsToF a) hab a)) b
-instance (UnToF a, UnToF b) => UnToFIf 'True (Either a b) where
- unToF (ha, hb) = \case
- Left a -> unToF @(Sym.IsToF a) ha a
- Right b -> unToF @(Sym.IsToF b) hb b
-instance UnToFIf 'False a where
- unToF = id
-
+-- | Nothing is needed at the 'Endpoint' for building an 'Address'.
+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]}
+ pathSegment s = Addresser \f -> f Address{addressPath = [s]}
instance Sym.SumFunctor Addresser where
a <+> b = Addresser \n -> (unAddresser a n, unAddresser b n)
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)
-
instance
( Generic a
, Sym.EoTOfRep a
, sem ~ Addresser
, Sym.IsToF a ~ 'False
, e ~ Sym.EoT (Sym.ADT a)
- , UnToF e
- ) => Dataable__ a Addresser where
- data__ :: sem (Sym.EoT (Sym.ADT a)) -> sem a
- data__ a = Addresser (\a2n -> unToF @(Sym.IsToF e) @e (unAddresser a a2n) . Sym.eotOfadt)
+ , Sym.ToFable e
+ ) =>
+ Dataable a Addresser
+ 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
+ optional aA = Addresser \k -> \case
+ Nothing -> k mempty
+ Just a -> unAddresser aA k a
-instance end ~ Address => Responsable a ts m end (Addresser) where
+instance (end ~ Address) => Responsable a ts m (Addresser) where
response = Addresser ($ mempty)
-- ** Type 'Address'
-- For CompilerToF
+{-# LANGUAGE AllowAmbiguousTypes #-}
+-- For CompilerToF
{-# LANGUAGE ConstraintKinds #-}
+-- For Dataable
+{-# LANGUAGE InstanceSigs #-}
-- For Output
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE RankNTypes #-}
-- For CompilerToF
{-# LANGUAGE UndecidableInstances #-}
--- For CompilerToF
-{-# LANGUAGE AllowAmbiguousTypes #-}
--- For Output
-{-# LANGUAGE RankNTypes #-}
--- For Dataable__
-{-# LANGUAGE InstanceSigs #-}
module Literate.Web.Semantics.Compiler where
import Control.Applicative (Applicative (..))
-import Control.Monad (Monad (..), forM, forM_, join, sequence, (>=>))
+import Control.Monad (Monad (..), forM_)
import Control.Monad.Classes qualified as MC
-import Control.Monad.Trans.Class qualified as MT
-import Control.Monad.Trans.Reader qualified as MT
import Data.Bool
import Data.ByteString.Lazy qualified as BSL
import Data.Either (Either (..))
-import Data.Eq (Eq (..))
import Data.Foldable (toList)
-import Data.Function (const, id, ($), (.))
+import Data.Function (id, ($), (.))
import Data.Functor (Functor (..), (<$>))
-import Data.Kind (Constraint, Type)
import Data.List qualified as List
import Data.Maybe (Maybe (..))
-import Data.Ord (Ord (..))
import Data.Proxy (Proxy (..))
import Data.Semigroup (Semigroup (..))
-import Data.String (fromString)
import Data.Text (Text)
import Data.Text qualified as Text
-import Data.Tuple (curry, fst, snd)
+import Data.Tuple (fst, snd)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Literate.Web.Syntaxes
import System.IO qualified as Sys
import Text.Show (Show (..))
import Type.Reflection ((:~:) (..))
-import Prelude (undefined)
-- * Type 'Compiler'
-newtype Compiler m a = Compiler {unCompiler :: {-FIXME: is m required?-}m [Output a]}
- -- deriving (Functor)
+
+-- | Interpreter building a static Web site.
+--
+-- Embed a 'Monad' @m@ to give access to a model if need be.
+newtype Compiler m a = Compiler {unCompiler :: m [Output a]}
+
+type instance Sym.ToFEndpoint (Compiler m) a next = (next :~: m BSL.ByteString, a)
+
+contentEndpoint :: a -> Sym.ToFEndpoint (Compiler m) a (m BSL.ByteString)
+contentEndpoint = (Refl,)
compile ::
- MC.MonadExec Sys.IO m =>
+ (MC.MonadExec Sys.IO m) =>
CompilerEnv ->
Compiler m a ->
- CompilerToF a (m BSL.ByteString) ->
+ (a --> m BSL.ByteString) ->
m ()
compile CompilerEnv{..} router content = do
outputs <- unCompiler router
forM_ outputs $ \Output{..} -> do
let destPath =
( List.intercalate "." $
- encodePath outputPath :
- ( if List.null outputExts
- then ["txt"]
- else Text.unpack . encodePathSegment <$> outputExts
- )
+ encodePath outputPath
+ : ( if List.null outputExts
+ then ["txt"]
+ else Text.unpack . encodePathSegment <$> outputExts
+ )
)
-- hPutStrLn stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
MC.exec @Sys.IO $
BSL.writeFile (compilerEnvDest Sys.</> destPath) $
bsl
+outputBSL :: Output a -> (a --> m BSL.ByteString) -> m BSL.ByteString
+outputBSL = outputData
-compi :: Compiler m (m BSL.ByteString) -> Compiler m (m BSL.ByteString)
-compi = id
+compiler :: Compiler m (m BSL.ByteString) -> Compiler m (m BSL.ByteString)
+compiler = id
-- compile2 ::
-- MC.MonadExec Sys.IO m =>
-- BSL.writeFile (compilerEnvDest Sys.</> destPath) $
-- outputBSL
-manifest :: forall m a. Monad m => Compiler m a -> m [Sys.FilePath]
+manifest :: forall m a. (Monad m) => Compiler m a -> m [Sys.FilePath]
manifest router = do
outputs <- unCompiler router
return
| out <- outputs
, let destPath =
( List.intercalate "." $
- encodePath (outputPath out) :
- ( if List.null (outputExts out)
- then ["txt"]
- else Text.unpack . encodePathSegment <$> outputExts out
- )
+ encodePath (outputPath out)
+ : ( if List.null (outputExts out)
+ then ["txt"]
+ else Text.unpack . encodePathSegment <$> outputExts out
+ )
)
]
-- { outputPath = outputPath oa <> outputPath ob
-- , outputExts = outputExts oa <> outputExts ob
-- }
-instance Applicative m => Sym.ProductFunctor (Compiler m) where
+instance (Applicative m) => Sym.ProductFunctor (Compiler m) where
Compiler a <.> Compiler b = Compiler $ liftA2 (liftA2 (<.>)) a b
Compiler a <. Compiler b = Compiler $ liftA2 (liftA2 (<.)) a b
Compiler a .> Compiler b = Compiler $ liftA2 (liftA2 (.>)) a b
---instance Applicative m => Sym.AlternativeFunctor (Compiler m) where
+
+-- instance Applicative m => Sym.AlternativeFunctor (Compiler m) where
-- Compiler a <|> Compiler b = Compiler (liftA2 (<>) a b)
-instance Applicative m => Sym.SumFunctor (Compiler m) where
+instance (Applicative m) => Sym.SumFunctor (Compiler m) where
Compiler a <+> Compiler b = Compiler $ liftA2 (\as bs -> (a2e <$> as) <> (b2e <$> bs)) a b
where
- a2e :: Output a -> Output (Either a b)
- a2e o = o{ outputData = outputData o . fst }
- b2e :: Output b -> Output (Either a b)
- b2e o = o{ outputData = outputData o . snd }
+ a2e :: Output a -> Output (Either a b)
+ a2e o = o{outputData = outputData o . fst}
+ b2e :: Output b -> Output (Either a b)
+ b2e o = o{outputData = outputData o . snd}
-instance (Applicative m, CompilerUnToF a) => Optionable a (Compiler m) where
+instance (Applicative m, Sym.ToFable a) => Optionable a (Compiler m) where
optional (Compiler ma) = Compiler $ (\as -> (a2n <$> as) <> (a2j <$> as)) <$> ma
where
- a2n :: Output a -> Output (Maybe a)
- a2n o = o{ outputData = ($ Nothing) }
- a2j :: Output a -> Output (Maybe a)
- a2j o = o{ outputData = \k -> outputData o $ compilerUnToF @(CompilerIsToF a) $ k . Just }
+ a2n :: Output a -> Output (Maybe a)
+ a2n o = o{outputData = ($ Nothing)}
+ a2j :: Output a -> Output (Maybe a)
+ a2j o = o{outputData = \k -> outputData o $ Sym.tofOffun $ k . Just}
+
-- optional (Compiler ma) = Compiler $ (\as -> (a2n <$> as) <> (a2j <$> as)) <$> ma
-- --pure Nothing Sym.<|> (Just <$> ma)
-- where
-- a2j :: Output a -> Output (Maybe a)
-- a2j o = o{ outputData = outputData o . snd }
--
--- ** Class 'CompilerUnToF'
-type CompilerUnToF a = CompilerUnToFIf (CompilerIsToF a) a
-class CompilerUnToFIf (t :: Bool) a where
- compilerUnToF :: (a -> next) -> CompilerToFIf t a next
-instance CompilerUnToFIf 'True () where
- compilerUnToF = ($ ())
-instance (CompilerUnToF a, CompilerUnToF b) => CompilerUnToFIf 'True (a, b) where
- compilerUnToF ab2n = compilerUnToF @(CompilerIsToF a) $ \a -> compilerUnToF @(CompilerIsToF b) $ \b -> ab2n (a,b)
-instance (CompilerUnToF a, CompilerUnToF b) => CompilerUnToFIf 'True (Either a b) where
- compilerUnToF e2n = ( compilerUnToF @(CompilerIsToF a) $ e2n . Left
- , compilerUnToF @(CompilerIsToF b) $ e2n . Right
- )
-instance CompilerUnToFIf 'False a where
- compilerUnToF = id
instance
( Generic a
, Sym.RepOfEoT a
, sem ~ Compiler m
- , CompilerIsToF a ~ 'False
- , e ~ Sym.EoT (Sym.ADT a)
- , CompilerUnToF e
+ , Sym.IsToF a ~ 'False
+ , eot ~ Sym.EoT (Sym.ADT a)
+ , Sym.ToFable eot
, Functor m
- ) => Dataable__ a (Compiler m) where
- data__ :: sem (Sym.EoT (Sym.ADT a)) -> sem a
- data__ (Compiler e) = Compiler ((data__ <$>) <$> e)
+ ) =>
+ Dataable a (Compiler m)
+ where
+ dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
+ dataType (Compiler mos) = Compiler ((dataType <$>) <$> mos)
instance
( Generic a
- --, Sym.EoTOfRep a
, Sym.RepOfEoT a
, sem ~ Output
- , CompilerIsToF a ~ 'False
- --, CompilerIsToF eot ~ 'False
+ , Sym.IsToF a ~ 'False
, eot ~ Sym.EoT (Sym.ADT a)
- , CompilerUnToF eot
- ) => Dataable__ a Output where
- data__ :: sem (Sym.EoT (Sym.ADT a)) -> sem a
- data__ o = o { outputData = \k -> (outputData o) $ compilerUnToF @(CompilerIsToF eot) $ k . Sym.adtOfeot }
-instance Applicative m => PathSegmentable (Compiler m) where
- pathSegment s = Compiler $ pure
- [
- Output
- { outputPath = [s]
- , outputExts = []
- , outputData = id
- }
- ]
+ , Sym.ToFable eot
+ ) =>
+ Dataable a Output
+ where
+ dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
+ dataType o = o{outputData = \k -> (outputData o) $ Sym.tofOffun $ k . Sym.adtOfeot}
+instance (Applicative m) => PathSegmentable (Compiler m) where
+ pathSegment s =
+ Compiler $
+ pure
+ [ Output
+ { outputPath = [s]
+ , outputExts = []
+ , outputData = id
+ }
+ ]
instance
- ( Show a
- , Monad m
+ ( Applicative m
, n ~ m
- , end ~ m BSL.ByteString
, MimeTypes ts (MimeEncodable a)
) =>
- Responsable a ts n end (Compiler m)
+ Responsable a ts n (Compiler m)
where
- response = Compiler $ pure $
- ( \(_mediaType, MimeType (Proxy :: Proxy t)) ->
- Output
- { outputPath = []
- , outputExts = [decodePathSegment (fileExtension @t)]
- , outputData = \(Refl, Response ma) -> do
- a <- ma
- pure $ mimeEncode @_ @t a
- }
- )
- <$> toList (mimeTypesMap @ts @(MimeEncodable a))
+ response =
+ Compiler $
+ pure $
+ ( \(_mediaType, MimeType (Proxy :: Proxy t)) ->
+ Output
+ { outputPath = []
+ , outputExts = [decodePathSegment (fileExtension @t)]
+ , outputData = \(Refl, Response ma) -> mimeEncode @_ @t <$> ma
+ }
+ )
+ <$> toList (mimeTypesMap @ts @(MimeEncodable a))
-- ** Type 'CompilerEnv'
data CompilerEnv = CompilerEnv
{ compilerEnvDest :: Sys.FilePath
, -- , compilerEnvSource :: Sys.FilePath
compilerEnvIndex :: Sys.FilePath
- --, compilerEnvModel :: model
+ -- , compilerEnvModel :: model
-- , compilerEnvPath :: [PathSegment]
}
deriving (Show)
-- ** Type 'Output'
+
-- TODO: use Seq instead of []
data Output a = Output
{ outputPath :: [PathSegment]
, outputExts :: [PathSegment]
- , outputData :: forall next. CompilerToF a next -> next
- --, outputBSL :: BSL.ByteString
- -- , outputType :: MimeType (MimeEncodable a)
+ , outputData :: forall next. (a --> next) -> next
}
-
--- instance Sym.SumFunctor Output where
--- a <+> b = Output
--- { outputPath = outputPath a <> outputPath b
--- , outputExts = outputExts a <> outputExts b
--- , outputData = \(a2n, b2n) -> outputData a a2n
--- }
instance Sym.ProductFunctor Output where
- a <.> b = Output
- { outputPath = outputPath a <> outputPath b
- , outputExts = outputExts a <> outputExts b
- , outputData = outputData b . outputData a
- }
- a <. b = Output
- { outputPath = outputPath a <> outputPath b
- , outputExts = outputExts a <> outputExts b
- , outputData = outputData b . outputData a
- }
- a .> b = Output
- { outputPath = outputPath a <> outputPath b
- , outputExts = outputExts a <> outputExts b
- , outputData = outputData b . outputData a
- }
--- deriving (Functor, Show)
--- instance Applicative Output where
--- pure a =
--- Output
--- { outputPath = []
--- , outputExts = []
--- , outputData = a
--- --, outputBSL = ""
--- -- , outputType = mediaType @PlainText
--- }
--- oa2b <*> oa =
--- Output
--- { outputPath = outputPath oa2b <> outputPath oa
--- , outputExts = outputExts oa2b <> outputExts oa
--- , outputData = outputData oa2b (outputData oa)
--- --, outputBSL = outputBSL oa2b <> outputBSL oa
--- }
-
-
--- * Type family 'CompilerToF'
-type CompilerToF a next = CompilerToFIf (CompilerIsToF a) a next
-type family CompilerToFIf t a next :: Type where
--- For '<.>': curry.
- CompilerToFIf 'True (a, b) next = CompilerToF a (CompilerToF b next)
--- For '<+>', request both branches.
- CompilerToFIf 'True (Either l r) next = (CompilerToF l next, CompilerToF r next)
- --CompilerToFIf 'True (Maybe a) next = (CompilerToF () next, CompilerToF a next)
--- Useless to ask '()' as argument.
- CompilerToFIf 'True () next = next
--- Enable a different return value for each function.
- CompilerToFIf 'True (Sym.Endpoint end a) next = (next :~: end, a)
--- Everything else becomes a new argument.
- CompilerToFIf 'False a next = a -> next
-
-
--- | This 'Bool' is added to 'ToFIf' to avoid overlapping instances.
-type family CompilerIsToF a :: Bool where
- CompilerIsToF () = 'True
- CompilerIsToF (a, b) = 'True
- CompilerIsToF (Either l r) = 'True
- --CompilerIsToF (Maybe a) = 'True
- CompilerIsToF (Sym.Endpoint end a) = 'True
- CompilerIsToF a = 'False
-
+ a <.> b =
+ Output
+ { outputPath = outputPath a <> outputPath b
+ , outputExts = outputExts a <> outputExts b
+ , outputData = outputData b . outputData a
+ }
+ a <. b =
+ Output
+ { outputPath = outputPath a <> outputPath b
+ , outputExts = outputExts a <> outputExts b
+ , outputData = outputData b . outputData a
+ }
+ a .> b =
+ Output
+ { outputPath = outputPath a <> outputPath b
+ , outputExts = outputExts a <> outputExts b
+ , outputData = outputData b . outputData a
+ }
--- -- pathSegments _ss = Compiler $
--- -- MT.ReaderT $ \s ->
--- -- -- TODO: assert Set.member s ss
--- -- lift $
--- -- MT.modify' $ \st ->
--- -- st{compilerStatePath = compilerStatePath st </> Text.unpack (encodePathSegment s)}
---
--- {-
--- instance
--- TypeError (
--- 'Text "The instance (Capturable a Compiler)"
--- ':$$: 'Text "is disabled when compiling to a static Web site."
--- ':$$: 'Text "You can use (whenInterpreter @Compiler siteNotUsingCapturable siteUsingCapturable)"
--- ':$$: 'Text "to replace calls to any method of Capturable."
--- ) => Capturable a Compiler where
--- capturePathSegment = undefined
--- instance
--- TypeError (
--- 'Text "The instance (Capturable a (Reader model Compiler))"
--- ':$$: 'Text "is disabled when compiling to a static Web site."
--- ':$$: 'Text "You can use (whenInterpreter @(Reader model Compiler) siteNotUsingCapturable siteUsingCapturable)"
--- ':$$: 'Text "to replace calls to any method of Capturable."
--- ) => Capturable a (Reader model Compiler) where
--- capturePathSegment = undefined
--- -}
---
--- -- choosePathSegments _s = Compiler $ MT.ReaderT $ \s -> return $ Endo (List.reverse s <>)
--- {-
--- instance Capturable Compiler where
--- type CapturableConstraint Compiler =
--- capturePathSegment _n = Compiler $ MT.ReaderT $ \s ->
--- lift $ MT.modify' $ \st ->
--- st{compilerStatePath = compilerStatePath st </> Text.unpack (encodePathSegment s)}
--- -}
--- {-
--- instance Copyable Compiler where
--- copy path = Compiler $
--- lift $
--- MT.ReaderT $ \env -> do
--- lift $ do
--- doesPathExist (compilerEnvSource env </> path) >>= \case
--- True -> do
--- Sys.hPutStrLn Sys.stderr $
--- "staticCopy: "
--- <> show
--- ( (compilerEnvSource env </> path)
--- , (compilerEnvDest env </> path)
--- )
--- copyDirRecursively
--- path
--- (compilerEnvSource env </> path)
--- (compilerEnvDest env)
--- False -> do
--- Sys.hPutStrLn Sys.stderr $ "error: path does not exist: " <> (compilerEnvSource env </> path)
--- instance Encodable fmt a => Contentable fmt a Compiler where
--- content = Compiler $
--- MT.ReaderT $ \a -> MT.ReaderT $ \env -> do
--- st <- MT.get
--- let destPath = compilerEnvDest env </> compilerStatePath st
--- lift $ do
--- -- Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
--- createDirectoryIfMissing True (Sys.takeDirectory destPath)
--- -- Sys.hPutStrLn Sys.stderr $ "write: " <> show destPath
--- BSL.writeFile destPath $ encode @fmt a
--- -}
--- --instance Endable Compiler where
--- -- end = Compiler $ return $ Endo id
---
--- --pathSegments _cs = Compiler $ MT.ReaderT $ \s -> return $ Endo (s :)
--- -- instance Fileable Compiler where
--- -- type FileableConstraint Compiler = Typeable
--- -- static = Compiler $ MT.ReaderT $ \_a ->
--- -- return $ Endo (\x -> x)
---
--- {-
--- -- * The 'Compiler' interpreter
---
--- -- | Create files according to the given model of type 'a'.
--- newtype Compiler a = Compiler
--- { unCompiler :: [Comp a]
--- }
--- deriving (Show, Functor)
---
--- instance Applicative Compiler where
--- pure = Compiler . pure . pure
--- Compiler f <*> Compiler x = Compiler $ (<*>) <$> f <*> x
---
--- -- instance Monad Compiler where
--- -- return = pure
--- -- Compiler x >>= f = Compiler (x >>=)
---
-- compile :: Show a => Renderable a => Compiler a -> CompilerEnv -> Sys.IO ()
-- compile compiler conf@CompilerEnv{..} = do
-- createDirectoryIfMissing True compilerEnvDest
-- createDirectoryIfMissing True (Sys.takeDirectory destPath)
-- -- Sys.hPutStrLn Sys.stderr $ "write: " <> show destPath
-- BSL.writeFile destPath bs
---
--- -- ** Class 'Renderable'
--- class Renderable a where
--- render :: a -> Either Sys.FilePath BSL.ByteString
--- instance Renderable () where
--- render () =
--- --Left $ pathOfPathSegments compPathSegments
--- Right BSL.empty
---
--- -- ** Type 'Comp'
--- data Comp a = Comp
--- { compPathSegments :: [PathSegment] -- TODO: Endo? Seq?
--- , compData :: a
--- -- , compType :: MimeType (MimeEncodable a)
--- }
--- deriving instance Eq a => Eq (Comp a)
--- deriving instance Ord a => Ord (Comp a)
--- deriving instance Show a => Show (Comp a)
--- deriving instance Functor Comp
--- instance Applicative Comp where
--- pure compData =
--- Comp
--- { compPathSegments = []
--- , compData
--- -- , compType = mediaType @PlainText
--- }
--- f <*> x =
--- Comp
--- { compPathSegments = compPathSegments f <> compPathSegments x
--- , compData = compData f (compData x)
--- -- , compType = compType f <> compType x
--- }
---
--- instance IsoFunctor Compiler where
--- (<%>) Iso{..} = (a2b <$>)
--- instance ProductFunctor Compiler where
--- (<.>) = liftA2 (,)
--- (<.) = (<*)
--- (.>) = (*>)
--- instance SumFunctor Compiler where
--- x <+> y =
--- Compiler $
--- (<>)
--- ((Left <$>) <$> unCompiler x)
--- ((Right <$>) <$> unCompiler y)
--- instance Optionable Compiler where
--- optional x =
--- Compiler $
--- Comp { compPathSegments = []
--- , compData = Nothing
--- -- , compType = Nothing
--- } :
--- ((Just <$>) <$> unCompiler x)
--- instance PathSegmentable Compiler where
--- pathSegment s = Compiler
--- [
--- Comp
--- { compPathSegments = [s]
--- , compData = ()
--- -- , compType = PlainText
--- }
--- ]
--- pathSegments ss =
--- Compiler $
--- [ Comp{ compPathSegments = [s]
--- , compData = s
--- -- , compType = Nothing
--- }
--- | s <- toList ss
--- ]
--- instance ContentTypeable PlainText () Compiler where
--- contentType =
--- Compiler
--- [ Comp
--- { compPathSegments = []
--- , compData = ()
--- --, compType = mediaType @PlainText
--- }
--- ]
---
--- -- instance Repeatable Compiler where
--- -- many0 (Compiler x) =
--- -- Compiler $
--- -- ((\Comp{} -> Comp [] []) <$> x)
--- -- <> ((\(Comp s a) -> Comp s [a]) <$> x)
--- -- <> ((\(Comp s a) -> Comp (s <> s) [a, a]) <$> x)
--- -- many1 (Compiler x) =
--- -- Compiler $
--- -- ((\(Comp s a) -> Comp s [a]) <$> x)
--- -- <> ((\(Comp s a) -> Comp (s <> s) [a, a]) <$> x)
--- -- instance Endable Compiler where
--- -- end = Compiler [Comp [] ()]
--- -- instance Capturable Compiler where
--- -- capturePathSegment n = Compiler $ [Comp [n] n]
--- -- instance Constantable c Compiler where
--- -- constant = pure
--- -}
---
+
copyDirRecursively ::
- ( --MonadIO m,
- --MonadUnliftIO m,
- --MonadLoggerIO m,
- HasCallStack
- ) =>
+ (HasCallStack) =>
-- | Source file path relative to CWD
Sys.FilePath ->
-- | Absolute path to source file to copy.
copyDirRecursively srcRel srcAbs destParent = do
Sys.doesFileExist srcAbs >>= \case
True -> do
- Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a file", srcAbs)
+ Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a file" :: Text, srcAbs)
copyFileCreatingParents srcAbs (destParent Sys.</> srcRel)
False ->
Sys.doesDirectoryExist srcAbs >>= \case
False -> do
- Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is neither a file nor directory", srcAbs)
+ Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is neither a file nor directory" :: Text, srcAbs)
return ()
-- throw $ StaticAssetMissing srcAbs
True -> do
- Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a directory", srcAbs)
+ Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a directory" :: Text, srcAbs)
Sys.createDirectoryIfMissing True (destParent Sys.</> srcRel)
fs <- Sys.getDirectoryFiles srcAbs ["**"]
forM_ fs $ \fp -> do
Dataable (..),
Inferable (..),
IsoFunctor (..),
- dataType,
pattern (:!:),
+ Endpoint (..),
+ ToFEndpoint,
+ ToFable,
+ type (-->),
) where
import Control.Applicative (Applicative)
import Control.Monad (Monad)
import Control.Monad.Classes qualified as MC
import Control.Monad.Trans.Class as MT
-import Data.Either (Either)
import Data.Bool (Bool (..))
import Data.ByteString.Lazy qualified as BSL
+import Data.Either (Either (..))
import Data.Function ((.))
import Data.Functor as Functor
-import Data.Maybe (Maybe)
import Data.Kind (Constraint, Type)
+import Data.Maybe (Maybe)
import Data.Typeable (Typeable)
import Literate.Web.Types.URL
-import Literate.Web.Types.MIME
import Symantic.Semantics (Reader (..))
-import Symantic qualified as Sym
-import GHC.Generics (Generic)
-import Symantic.Semantics.ToFer (
- ToFer (..),
- )
+import Symantic.Semantics.Data (Data, SomeData (..))
import Symantic.Syntaxes (
Dataable (..),
- Endpoint,
+ Endpoint (..),
Inferable (..),
- IsToF,
IsoFunctor (..),
ProductFunctor (..),
Repeatable (..),
SumFunctor (..),
+ ToFEndpoint,
+ ToFable,
dataType,
pattern (:!:),
+ type (-->),
)
-import Symantic.Syntaxes.Data (Data, SomeData (..))
-import Symantic.Syntaxes.Derive
+import Symantic.Syntaxes.Derive hiding (Semantic)
import System.FilePath (FilePath)
---deriving instance PathSegmentable sem => PathSegmentable (Reflector r sem)
---deriving instance Endable sem => Endable (Reflector r sem)
---deriving instance Capturable sem => Capturable (Reflector r sem)
+-- deriving instance PathSegmentable sem => PathSegmentable (Reflector r sem)
+-- deriving instance Endable sem => Endable (Reflector r sem)
+-- deriving instance Capturable sem => Capturable (Reflector r sem)
-- * Class 'PathSegmentable'
-- pathSegment :: PathSegment -> sem a -> sem a
pathSegment :: PathSegment -> sem ()
- default pathSegment :: FromDerived PathSegmentable sem => PathSegment -> sem ()
+ default pathSegment :: (FromDerived PathSegmentable sem) => PathSegment -> sem ()
-- default pathSegment :: IsoFunctor sem => PathSegment -> sem ()
-- pathSegment s = Iso (const ()) (const s) <%> pathSegments (Set.singleton s)
pathSegment = liftDerived . pathSegment
-instance (PathSegmentable sem, Functor sem) => PathSegmentable (ToFer sem) where
- pathSegment s =
- ToFer
- { tuplesOfFunctions = (Functor.<$ eot)
- , eithersOfTuples = eot
- }
- where
- eot = pathSegment s
-
-- pathSegments :: Set PathSegment -> sem PathSegment
-- default pathSegments :: FromDerived PathSegmentable sem => Set PathSegment -> sem PathSegment
-- pathSegments = liftDerived . pathSegments
-- ChoosePathSegments :: Set [PathSegment] -> Data PathSegmentable sem [PathSegment]
-- | Initial to final algebra.
-instance PathSegmentable sem => Derivable (Data PathSegmentable sem) where
+instance (PathSegmentable sem) => Derivable (Data PathSegmentable sem) where
derive = \case
PathSegment x -> pathSegment x
-- ChoosePathSegments x -> choosePathSegments x
-- | Final to initial algebra.
-instance PathSegmentable sem => PathSegmentable (SomeData sem) where
+instance (PathSegmentable sem) => PathSegmentable (SomeData sem) where
pathSegment = SomeData . PathSegment
-- pathSegments = SomeData . PathSegments
---choosePathSegments = SomeData . ChoosePathSegments
+-- choosePathSegments = SomeData . ChoosePathSegments
-- | Convenient alias for an @index.html@ page.
-index :: PathSegmentable sem => sem ()
+index :: (PathSegmentable sem) => sem ()
index = pathSegment "index.html"
-- | Convenient alias for prefixing with a 'pathSegment'.
(</>) ::
- ProductFunctor sem =>
- PathSegmentable sem =>
+ (ProductFunctor sem) =>
+ (PathSegmentable sem) =>
PathSegment ->
sem a ->
sem a
type Captured a sem = a
capturePathSegment :: PathSegment -> sem (Captured a sem)
default capturePathSegment ::
- Captured a (Derived sem) ~ Captured a sem =>
- FromDerived (Capturable a) sem =>
+ (Captured a (Derived sem) ~ Captured a sem) =>
+ (FromDerived (Capturable a) sem) =>
PathSegment ->
sem (Captured a sem)
capturePathSegment = liftDerived . capturePathSegment @a
--- | The @('IsToF' a ~ 'False)@ constraint
--- disables capturing tuples or functions.
-instance
- ( Capturable a sem
- , IsToF (Captured a sem) ~ 'False
- , Functor sem
- ) => Capturable a (ToFer sem) where
- type Captured a (ToFer sem) = Captured a sem
- capturePathSegment _n =
- ToFer
- { tuplesOfFunctions = \next -> next <$> capturePathSegment @a _n
- , eithersOfTuples = capturePathSegment @a _n
- }
-
-- | @('CapturedExtra' a extra)@ is useful to add @(extra)@ data
-- to a 'Captured' value, eg. when using the 'Compiler' semantic,
-- to add the content of a page whose name was captured
-- when using the 'Server' semantic.
newtype CapturedExtra a extra = CapturedExtra (Either (a, extra) a)
---instance Capturable sem => Capturable (Reader r sem)
+-- instance Capturable sem => Capturable (Reader r sem)
data instance Data (Capturable a) sem r where
CapturePathSegment ::
- Capturable a sem =>
+ (Capturable a sem) =>
PathSegment ->
Data (Capturable a) sem (Captured a sem)
-instance Capturable a sem => Derivable (Data (Capturable a) sem) where
+instance (Capturable a sem) => Derivable (Data (Capturable a) sem) where
derive = \case
CapturePathSegment n -> capturePathSegment @a n
instance (Capturable a sem, Typeable a) => Capturable a (SomeData sem) where
class Fileable sem where
type FileableConstraint sem :: Type -> Constraint
static :: sem ()
- dynamic :: FileableConstraint sem a => sem a
+ dynamic :: (FileableConstraint sem a) => sem a
-- * Class 'Responsable'
-class Responsable a (ts::[Type]) (m::Type -> Type) end sem where
- --type Responsed a (ts::[Type]) (m::Type -> Type) end sem
- --type Responsed a ts m end sem = Endpoint end (Response ts m a)
- --response :: sem (Responsed a ts m end sem)
- response :: sem (Endpoint end (Response ts m a))
-class Responsable2 a (ts::[Type]) sem where
- response2 :: MimeTypes ts (MimeEncodable a) => sem a -> sem a
+class Responsable a (ts :: [Type]) (m :: Type -> Type) sem where
+ -- type Responsed a (ts::[Type]) (m::Type -> Type) end sem
+ -- type Responsed a ts m end sem = Endpoint end (Response ts m a)
+ -- response :: sem (Responsed a ts m end sem)
+ response :: sem (Endpoint sem (Response ts m a))
-- ** Type 'Response'
newtype Response (ts :: [Type]) m a = Response {unResponse :: m a}
type instance MC.CanDo (Response ts m) eff = 'False
instance MT.MonadTrans (Response ts) where lift = Response
-class Generic a => Dataable__ a sem where
- data__ :: sem (Sym.EoT (Sym.ADT a)) -> sem a
-
-- ** Class 'Optionable'
class Optionable a sem where
optional :: sem a -> sem (Maybe a)
optional = liftDerived1 optional
default optional ::
- FromDerived1 (Optionable a) sem =>
+ (FromDerived1 (Optionable a) sem) =>
sem a ->
sem (Maybe a)
import Control.Monad (Monad (..))
import Data.Text (Text)
import Literate.Web
-import Symantic qualified as Sym
-- | Polymorphic expression describing the website,
-- to be instantiated to the various interpreters.
-- NoMonomorphismRestriction is used to avoid specifying manually
-- the inferred symantic classes.
router =
- pathSegment "index" <.> response @Text @'[PlainText]
- <+> "about" </> pathSegment "me"
+ pathSegment "index"
+ <.> response @Text @'[PlainText]
+ <+> "about"
+ </> pathSegment "me"
content =
- (Sym.endpoint (return "INDEX"), return "ABOUT")
+ ( contentEndpoint (return "INDEX")
+ , return "ABOUT"
+ )
+
+-- c0 = compile CompilerEnv{} router content
+-- m0 = manifest router
+
+address_Index, address_About :: Address
+(address_Index :!: address_About) = address router
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
-- from the 'Route' algebraic data-type
-- a function transforming Eithers-of-Tuples into a 'Route'.
router =
- dataType @Route $
- pathSegment "index"
- <+> "about"
- </> pathSegment "me"
+ dataType @Route
+ $ pathSegment "index" -- <.> response @Char @'[PlainText]
+ <+> "about"
+ </> pathSegment "me"
+
+-- <. response2 @Char @'[PlainText]
content = \case
- Index -> return "INDEX"
+ -- In -> Out
+ Index{} -> return "INDEX"
About -> return "ABOUT"
+
+-- c0 = compile CompilerEnv{} router content
+
+address_IndexMe :: Address
+address_IndexMe = address router Index
+
+address_AboutMe :: Address
+address_AboutMe = address router About
router =
pathSegment "static"
<+> pathSegment "feed"
- <+> "filter" </> (dataType @(Maybe Lang) $ pathSegment "all" <+> infer) <.> optional (capturePathSegment @Tag "tag")
+ <+> "filter"
+ </> (dataType @(Maybe Lang) $ pathSegment "all" <+> infer)
+ <.> optional (capturePathSegment @Tag "tag")
-- content ::
-- Monad m =>
Nothing -> show lang
Just tag -> show (lang, tag)
+-- c0 = compile CompilerEnv{} router content
+
+address_static, address_feed :: Address
+address_filter :: Maybe Lang -> Maybe (Captured Tag Addresser) -> Address
+( address_static
+ :!: address_feed
+ :!: address_filter
+ ) = address router
+
-- * Type 'Lang'
data Lang
= LangEn
-- | Using 'Inferable' has the downside of requiring
-- to explicit manually the symantices required.
-instance (SumFunctor sem, PathSegmentable sem, Dataable sem) => Inferable Lang sem where
+instance (SumFunctor sem, PathSegmentable sem, Dataable Lang sem) => Inferable Lang sem where
infer = routeLang
-- * Type 'Tag'
-- Hence the 'Compiler' semantic for 'Capturable'
-- requires a readable 'Model' somewhere in the monad stack
-- in order to generate all 'Tag's folders.
-instance MC.MonadReader Model m => Capturable Tag (Compiler m) where
+instance (MC.MonadReader Model m) => Capturable Tag (Compiler m) where
capturePathSegment _n =
Compiler do
model <- MC.ask
return
- [ Output{outputPath = [unTag tag], outputExts = [], outputData = tag}
+ [ Output{outputPath = [unTag tag], outputExts = [], outputData = ($ tag)}
| tag <- Set.toList (modelTags model)
]
+instance Capturable Tag Addresser where
+ -- FIXME: check given tag exists?
+ capturePathSegment _n = Addresser \k t -> k (Address [unTag t])
+
-- * Type 'Model'
data Model = Model
{ modelTags :: Set Tag
module Examples.Ex04 where
import Control.Monad.Classes qualified as MC
+
+-- import Control.Reactive
import Data.Map.Strict as Map
import Literate.Web
import Relude
-import Symantic qualified as Sym
router =
- "post" </> capturePathSegment @PostName "post" <.> response @Post @'[PlainText]
- <+> "page" </> capturePathSegment @PageName "page" <.> response @Page @'[PlainText]
+ "post"
+ </> capturePathSegment @PostName "post"
+ <.> response @Post @'[PlainText]
+ <+> "page"
+ </> capturePathSegment @PageName "page"
+ <.> response @Page @'[PlainText]
<+> pathSegment "lorem"
-- content ::
-- endpoint
content = contentPost :!: contentPage :!: contentOther
where
- contentPost n = Sym.endpoint do
+ contentPost n = contentEndpoint do
Model{..} <- MC.ask
return $ modelPosts Map.! n
- contentPage = Sym.endpoint . \case
- CapturedExtra (Left (_n, p)) -> do
- return p
- CapturedExtra (Right n) -> do
- Model{..} <- MC.ask
- return $ modelPages Map.! n
+ contentPage =
+ contentEndpoint . \case
+ CapturedExtra (Left (_n, p)) -> do
+ return p
+ CapturedExtra (Right n) -> do
+ Model{..} <- MC.ask
+ return $ modelPages Map.! n
contentOther = return "ipsum"
+-- c0 = compile CompilerEnv{} router content
+
instance MimeEncodable Post PlainText where
mimeEncode (Post t) = mimeEncode @_ @PlainText t
instance MimeEncodable Page PlainText where
mimeEncode (Page t) = mimeEncode @_ @PlainText t
-instance MC.MonadReader Model m => Capturable PostName (Compiler m) where
+instance (MC.MonadReader Model m) => Capturable PostName (Compiler m) where
capturePathSegment _n =
Compiler do
model <- MC.ask
return
- [ Output{outputPath = [unPostName name], outputExts = [], outputData = name}
+ [ Output{outputPath = [unPostName name], outputExts = [], outputData = ($ name)}
| name <- Map.keys (modelPosts model)
]
-instance MC.MonadReader Model m => Capturable PageName (Compiler m) where
+instance (MC.MonadReader Model m) => Capturable PageName (Compiler m) where
-- Keep the 'Page' to avoid looking it up in 'contentPage'.
type Captured PageName (Compiler m) = CapturedExtra PageName Page
capturePathSegment _n =
model <- MC.ask
return
[ Output
- { outputPath = [unPageName name]
- , outputExts = []
- , outputData = CapturedExtra (Left (name, page))
- }
+ { outputPath = [unPageName name]
+ , outputExts = []
+ , outputData = ($ CapturedExtra (Left (name, page)))
+ }
| (name, page) <- Map.toList (modelPages model)
]
+{-
+data Rodel m = Rodel
+ { rodelPosts :: RW m (Map PostName (RW m Post))
+ , rodelPages :: RW m (Map PageName (RW m Page))
+ }
+-}
+
-- * Type 'Model'
data Model = Model
{ modelPosts :: Map PostName Post
--- /dev/null
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# OPTIONS_GHC -Wno-missing-signatures #-}
+
+module Examples.Ex05 where
+
+import Literate.Web
+
+import Examples.Ex03 qualified as Ex03
+import Examples.Ex04 qualified as Ex04
+
+router =
+ "ex03"
+ </> Ex03.router
+ <+> "ex04"
+ </> Ex04.router
+
+content =
+ Ex03.content
+ :!: Ex04.content
+
+data Model = Model
+ { model03 :: Ex03.Model
+ , model04 :: Ex04.Model
+ }
+
+model1 =
+ Model
+ { model03 = Ex03.model1
+ , model04 = Ex04.model1
+ }
module Goldens where
-import Control.Monad.Classes qualified as MC
import Control.Monad.Trans.Reader as MT
-import Data.ByteString.Lazy qualified as BSL
-import Data.Functor.Identity (Identity (..))
-import Data.Text qualified as Text
import Relude
-import Symantic qualified as Sym
import System.FilePath qualified as Sys
import System.IO.Unsafe (unsafePerformIO)
import Test.Tasty
[
[ Golden
{ goldenCompiler = \env -> compile env Ex01.router Ex01.content
- , goldenManifest = runIdentity $ manifest Ex01.router Ex01.content
+ , goldenManifest = runIdentity $ manifest Ex01.router
}
]
,
[ Golden
{ goldenCompiler = \env -> compile env Ex02.router Ex02.content
- , goldenManifest = runIdentity $ manifest Ex02.router Ex02.content
+ , goldenManifest = runIdentity $ manifest Ex02.router
}
]
, [ Golden
{ goldenCompiler = \env -> MT.runReaderT (compile env Ex03.router Ex03.content) model
- , goldenManifest = runReader (manifest Ex03.router Ex03.content) model
+ , goldenManifest = runReader (manifest Ex03.router) model
}
| model <- [Ex03.model1, Ex03.model2]
]
, [ Golden
{ goldenCompiler = \env -> MT.runReaderT (compile env Ex04.router Ex04.content) model
- , goldenManifest = runReader (manifest Ex04.router Ex04.content) model
+ , goldenManifest = runReader (manifest Ex04.router) model
}
| model <- [Ex04.model1]
]
, [ Golden
{ goldenCompiler = \env -> MT.runReaderT (MT.runReaderT (compile env Ex05.router Ex05.content) model03) model04
- , goldenManifest = MT.runReader (MT.runReaderT (manifest Ex05.router Ex05.content) model03) model04
+ , goldenManifest = MT.runReader (MT.runReaderT (manifest Ex05.router) model03) model04
}
| model03 <- [Ex03.model1, Ex03.model2]
, model04 <- [Ex04.model1]
--- /dev/null
+ABOUT
\ No newline at end of file
--- /dev/null
+INDEX
\ No newline at end of file
--- /dev/null
+ABOUT
\ No newline at end of file
--- /dev/null
+INDEX
\ No newline at end of file
+++ /dev/null
-ALL-LANG-ALL-TAGS
\ No newline at end of file
+++ /dev/null
-LangEn
\ No newline at end of file
+++ /dev/null
-LangFr
\ No newline at end of file
+++ /dev/null
-ALL-LANG-ALL-TAGS
\ No newline at end of file
+++ /dev/null
-LangEn
\ No newline at end of file
+++ /dev/null
-LangFr
\ No newline at end of file
--- /dev/null
+page-model-2
\ No newline at end of file
--- /dev/null
+page-model-2
\ No newline at end of file
--- /dev/null
+page-model-2
\ No newline at end of file
+++ /dev/null
-ALL-LANG-ALL-TAGS
\ No newline at end of file
+++ /dev/null
-LangEn
\ No newline at end of file
+++ /dev/null
-LangFr
\ No newline at end of file
--- /dev/null
+page-model-2
\ No newline at end of file
--- /dev/null
+page-model-2
\ No newline at end of file
+++ /dev/null
-ALL-LANG-ALL-TAGS
\ No newline at end of file
+++ /dev/null
-LangEn
\ No newline at end of file
+++ /dev/null
-LangFr
\ No newline at end of file
--- /dev/null
+page-model-2
\ No newline at end of file
sourcephile / git / haskell / literate-web.git / commitdiff