Shpadoinkle-disembodied 0.0.0.1 → 0.0.0.2
raw patch · 5 files changed
+100/−99 lines, 5 files
Files
- CHANGELOG.md +0/−0
- README.md +1/−1
- Shpadoinkle-disembodied.cabal +29/−23
- Shpadoinkle/Disembodied.hs +62/−61
- Shpadoinkle/Disembodied/Sample.hs +8/−14
− CHANGELOG.md
README.md view
@@ -1,6 +1,6 @@ # Shpadoinkle Disembodied -[](https://gitlab.com/fresheyeball/Shpadoinkle)+[](https://gitlab.com/platonic/shpadoinkle) [](https://shpadoinkle.org/disembodied) [](https://opensource.org/licenses/BSD-3-Clause) [](https://builtwithnix.org)
Shpadoinkle-disembodied.cabal view
@@ -1,33 +1,38 @@-cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.33.0.------ see: https://github.com/sol/hpack------ hash: c9dcea41cbf0ee840bc68d0b857f3bf7b71f5d173c808dcd6c800cf9c9c11fc4--name: Shpadoinkle-disembodied-version: 0.0.0.1-synopsis: Shpadoinkle as a static site.-description: Static site backed SPA applications.-category: Web-author: Isaac Shapira-maintainer: fresheyeball@protonmail.com-license: BSD3-license-file: LICENSE-build-type: Simple+cabal-version: 2.2+name: Shpadoinkle-disembodied+version: 0.0.0.2+category: Web+author: Isaac Shapira+maintainer: isaac.shapira@platonic.systems+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple extra-source-files:- README.md- CHANGELOG.md+ README.md+synopsis:+ Shpadoinkle as a static site.+description:+ Static site backed SPA applications. + library exposed-modules: Shpadoinkle.Disembodied+ other-modules: Shpadoinkle.Disembodied.Sample- hs-source-dirs:- ./.- ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities++ hs-source-dirs: .++ ghc-options:+ -Wall+ -Wcompat+ -fwarn-redundant-constraints+ -fwarn-incomplete-uni-patterns+ -fwarn-tabs+ -fwarn-incomplete-record-updates+ -fwarn-identities+ build-depends: Shpadoinkle , Shpadoinkle-backend-static@@ -39,4 +44,5 @@ , servant , text >=1.2.3 && <1.3 , unliftio+ default-language: Haskell2010
Shpadoinkle/Disembodied.hs view
@@ -30,7 +30,7 @@ import Control.Monad (void) import Data.Kind (Type) import Data.Proxy (Proxy (..))-import Data.Text (unpack)+import Data.Text (isSuffixOf, pack, unpack) import Data.Text.IO as T (writeFile) import Servant.API import System.Directory (createDirectoryIfMissing)@@ -47,38 +47,38 @@ -- Site takes a context `ctx` which is universal for the static site. -- This is useful for storing commonly used valus like the site name, -- site url, copyright date, ect.-data Site ctx where+data Site where -- | A path segment in the URI SPath :: String -- ^ The current URI path segment- -> Site ctx+ -> Site -- ^ The site to be rendered at the path- -> Site ctx+ -> Site -- | Html to be rendered as @index.html@ SIndex- :: forall m a ctx- . (ctx -> Html m a)+ :: forall m a+ . Html m a -- ^ Given a context, how can we render a page?- -> Site ctx+ -> Site -- | Capture is the one Servant combinator that can be meaningful in static -- site generation, and only if we can generate all possible instances. SCapture :: (FromHttpApiData x, ToHttpApiData x, Bounded x, Enum x)- => (x -> Site ctx)+ => (x -> Site) -- ^ Given a context, provide the remaining site to be generated- -> Site ctx+ -> Site -- | Branch the site at a given point in generation.- SChoice :: Site ctx -> Site ctx -> Site ctx+ SChoice :: Site -> Site -> Site -- | Type class induction for building the site out of a specification-class Disembodied ctx a where+class Disembodied a where -- | A type family to represent the relationship between a Servant API -- and the 'Html' views to render. --@@ -90,108 +90,109 @@ -- site = const (h1_ [ text "about" ]) -- :\<|\> const (h1_ [ text "home" ]) -- @- type SiteSpec ctx a :: Type+ type SiteSpec a :: Type -- | Construct the site structure out of the associated API- buildSite :: SiteSpec ctx a -> Site ctx+ buildSite :: SiteSpec a -> Site -instance (Disembodied ctx x, Disembodied ctx y)- => Disembodied ctx (x :<|> y) where+instance (Disembodied x, Disembodied y)+ => Disembodied (x :<|> y) where - type SiteSpec ctx (x :<|> y) = SiteSpec ctx x :<|> SiteSpec ctx y+ type SiteSpec (x :<|> y) = SiteSpec x :<|> SiteSpec y - buildSite :: SiteSpec ctx x :<|> SiteSpec ctx y -> Site ctx- buildSite (x :<|> y) = SChoice (buildSite @ctx @x x) (buildSite @ctx @y y)+ buildSite :: SiteSpec x :<|> SiteSpec y -> Site+ buildSite (x :<|> y) = SChoice (buildSite @x x) (buildSite @y y) {-# INLINABLE buildSite #-} -instance (Disembodied ctx sub, KnownSymbol path)- => Disembodied ctx (path :> sub) where+instance (Disembodied sub, KnownSymbol path)+ => Disembodied (path :> sub) where - type SiteSpec ctx (path :> sub) = SiteSpec ctx sub+ type SiteSpec (path :> sub) = SiteSpec sub - buildSite :: SiteSpec ctx sub -> Site ctx- buildSite = SPath (symbolVal (Proxy @path)) . buildSite @ctx @sub+ buildSite :: SiteSpec sub -> Site+ buildSite = SPath (symbolVal (Proxy @path)) . buildSite @sub {-# INLINABLE buildSite #-} -instance (Disembodied ctx sub, FromHttpApiData x, ToHttpApiData x, Bounded x, Enum x)- => Disembodied ctx (Capture sym x :> sub) where+instance (Disembodied sub, FromHttpApiData x, ToHttpApiData x, Bounded x, Enum x)+ => Disembodied (Capture sym x :> sub) where - type SiteSpec ctx (Capture sym x :> sub) = x -> SiteSpec ctx sub+ type SiteSpec (Capture sym x :> sub) = x -> SiteSpec sub - buildSite :: (x -> SiteSpec ctx sub) -> Site ctx- buildSite = SCapture . (buildSite @ctx @sub .)+ buildSite :: (x -> SiteSpec sub) -> Site+ buildSite = SCapture . (buildSite @sub .) {-# INLINABLE buildSite #-} -instance Disembodied ctx sub- => Disembodied ctx (QueryParam sym x :> sub) where+instance Disembodied sub+ => Disembodied (QueryParam sym x :> sub) where - type SiteSpec ctx (QueryParam sym x :> sub) = Maybe x -> SiteSpec ctx sub+ type SiteSpec (QueryParam sym x :> sub) = Maybe x -> SiteSpec sub - buildSite :: (Maybe x -> SiteSpec ctx sub) -> Site ctx- buildSite f = buildSite @ctx @sub $ f Nothing+ buildSite :: (Maybe x -> SiteSpec sub) -> Site+ buildSite f = buildSite @sub $ f Nothing {-# INLINABLE buildSite #-} -instance Disembodied ctx sub- => Disembodied ctx (QueryParam' ms sym x :> sub) where+instance Disembodied sub+ => Disembodied (QueryParam' ms sym x :> sub) where - type SiteSpec ctx (QueryParam' ms sym x :> sub) = Maybe x -> SiteSpec ctx sub+ type SiteSpec (QueryParam' ms sym x :> sub) = Maybe x -> SiteSpec sub - buildSite :: (Maybe x -> SiteSpec ctx sub) -> Site ctx- buildSite f = buildSite @ctx @sub $ f Nothing+ buildSite :: (Maybe x -> SiteSpec sub) -> Site+ buildSite f = buildSite @sub $ f Nothing {-# INLINABLE buildSite #-} -instance Disembodied ctx sub- => Disembodied ctx (QueryParams sym x :> sub) where+instance Disembodied sub+ => Disembodied (QueryParams sym x :> sub) where - type SiteSpec ctx (QueryParams sym x :> sub) = [x] -> SiteSpec ctx sub+ type SiteSpec (QueryParams sym x :> sub) = [x] -> SiteSpec sub - buildSite :: ([x] -> SiteSpec ctx sub) -> Site ctx- buildSite f = buildSite @ctx @sub $ f []+ buildSite :: ([x] -> SiteSpec sub) -> Site+ buildSite f = buildSite @sub $ f [] {-# INLINABLE buildSite #-} -instance Disembodied ctx sub- => Disembodied ctx (QueryFlag sym :> sub) where+instance Disembodied sub+ => Disembodied (QueryFlag sym :> sub) where - type SiteSpec ctx (QueryFlag sym :> sub) = Bool -> SiteSpec ctx sub+ type SiteSpec (QueryFlag sym :> sub) = Bool -> SiteSpec sub - buildSite :: (Bool -> SiteSpec ctx sub) -> Site ctx- buildSite f = buildSite @ctx @sub $ f False+ buildSite :: (Bool -> SiteSpec sub) -> Site+ buildSite f = buildSite @sub $ f False {-# INLINABLE buildSite #-} -instance Disembodied ctx (f '[HTML] (Html m a)) where+instance Disembodied (f '[HTML] (Html m a)) where - type SiteSpec ctx (f '[HTML] (Html m a)) = ctx -> Html m a+ type SiteSpec (f '[HTML] (Html m a)) = Html m a - buildSite :: (ctx -> Html m a) -> Site ctx+ buildSite :: Html m a -> Site buildSite = SIndex {-# INLINABLE buildSite #-} -instance Disembodied ctx (View m a) where+instance Disembodied (View m a) where - type SiteSpec ctx (View m a) = ctx -> Html m a+ type SiteSpec (View m a) = Html m a - buildSite :: (ctx -> Html m a) -> Site ctx+ buildSite :: Html m a -> Site buildSite = SIndex {-# INLINABLE buildSite #-} -- | Actually write the site to disk. Branches are written in parallel. writeSite- :: forall layout ctx. Disembodied ctx layout+ :: forall layout. Disembodied layout => FilePath -- ^ Out path- -> ctx- -- ^ Universal context for the static site.- -> SiteSpec ctx layout+ -> SiteSpec layout -- ^ Specification for the pages of the site relative to a Servant API. -> IO ()-writeSite fs ctx layout = go fs $ buildSite @ctx @layout layout where+writeSite fs layout = go fs $ buildSite @layout layout where - go :: FilePath -> Site ctx -> IO ()- go curr (SIndex page) = T.writeFile (curr </> "index" <.> "html") . renderStatic $ page ctx+ go :: FilePath -> Site -> IO ()+ go curr (SIndex page) = T.writeFile (curr </> "index" <.> "html") $ renderStatic page go curr (SChoice x y) = void $ go curr x `concurrently` go curr y go curr (SCapture f) = forConcurrently_ [ minBound .. maxBound ] $ \c -> go curr $ SPath (unpack $ toUrlPiece c) $ f c+ go curr (SPath path (SIndex page)) | ".html" `isSuffixOf` pack path = do+ createDirectoryIfMissing False curr+ T.writeFile (curr </> path) $ renderStatic page go curr (SPath path site) = do createDirectoryIfMissing False (curr </> path) go (curr </> path) site
Shpadoinkle/Disembodied/Sample.hs view
@@ -9,10 +9,9 @@ module Shpadoinkle.Disembodied.Sample where -import Data.Text (Text) import Servant.API -import Shpadoinkle (Html, JSM, MonadJSM, text)+import Shpadoinkle (Html, JSM, MonadJSM) import Shpadoinkle.Disembodied (Disembodied (SiteSpec), writeSite) import Shpadoinkle.Html (button, h1_, onClick) import Shpadoinkle.Router (View)@@ -23,26 +22,21 @@ :<|> View m () -newtype Context = Context- { siteName :: Text }---about :: MonadJSM m => Context -> Html m Int-about ctx =- h1_ [ text $ "about us at " <> siteName ctx- , button+about :: MonadJSM m => Html m Int+about =+ h1_ [ button [ onClick (+ 1) ] [ "Increment" ] ] -home :: Html m a+home :: Monad m => Html m a home = h1_ [ "home" ] -site :: MonadJSM m => SiteSpec Context (Pages m)-site = about :<|> const home+site :: MonadJSM m => SiteSpec (Pages m)+site = about :<|> home makeSite :: IO ()-makeSite = writeSite @(Pages JSM) "" (Context "Sample") site+makeSite = writeSite @(Pages JSM) "" site