{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Shpadoinkle.Disembodied (
Site(..)
, Disembodied(..)
, writeSite
) where
import Control.Monad (void)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Data.Text (unpack)
import Data.Text.IO as T (writeFile)
import Servant.API
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((<.>), (</>))
import UnliftIO.Async (concurrently, forConcurrently_)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Shpadoinkle (Html)
import Shpadoinkle.Backend.Static (renderStatic)
import Shpadoinkle.Router (HTML, View)
data Site ctx where
SPath
:: String
-> Site ctx
-> Site ctx
SIndex
:: forall m a ctx
. (ctx -> Html m a)
-> Site ctx
SCapture
:: (FromHttpApiData x, ToHttpApiData x, Bounded x, Enum x)
=> (x -> Site ctx)
-> Site ctx
SChoice :: Site ctx -> Site ctx -> Site ctx
class Disembodied ctx a where
type SiteSpec ctx a :: Type
buildSite :: SiteSpec ctx a -> Site ctx
instance (Disembodied ctx x, Disembodied ctx y)
=> Disembodied ctx (x :<|> y) where
type SiteSpec ctx (x :<|> y) = SiteSpec ctx x :<|> SiteSpec ctx y
buildSite :: SiteSpec ctx x :<|> SiteSpec ctx y -> Site ctx
buildSite (x :<|> y) = SChoice (buildSite @ctx @x x) (buildSite @ctx @y y)
{-# INLINABLE buildSite #-}
instance (Disembodied ctx sub, KnownSymbol path)
=> Disembodied ctx (path :> sub) where
type SiteSpec ctx (path :> sub) = SiteSpec ctx sub
buildSite :: SiteSpec ctx sub -> Site ctx
buildSite = SPath (symbolVal (Proxy @path)) . buildSite @ctx @sub
{-# INLINABLE buildSite #-}
instance (Disembodied ctx sub, FromHttpApiData x, ToHttpApiData x, Bounded x, Enum x)
=> Disembodied ctx (Capture sym x :> sub) where
type SiteSpec ctx (Capture sym x :> sub) = x -> SiteSpec ctx sub
buildSite :: (x -> SiteSpec ctx sub) -> Site ctx
buildSite = SCapture . (buildSite @ctx @sub .)
{-# INLINABLE buildSite #-}
instance Disembodied ctx sub
=> Disembodied ctx (QueryParam sym x :> sub) where
type SiteSpec ctx (QueryParam sym x :> sub) = Maybe x -> SiteSpec ctx sub
buildSite :: (Maybe x -> SiteSpec ctx sub) -> Site ctx
buildSite f = buildSite @ctx @sub $ f Nothing
{-# INLINABLE buildSite #-}
instance Disembodied ctx sub
=> Disembodied ctx (QueryParam' ms sym x :> sub) where
type SiteSpec ctx (QueryParam' ms sym x :> sub) = Maybe x -> SiteSpec ctx sub
buildSite :: (Maybe x -> SiteSpec ctx sub) -> Site ctx
buildSite f = buildSite @ctx @sub $ f Nothing
{-# INLINABLE buildSite #-}
instance Disembodied ctx sub
=> Disembodied ctx (QueryParams sym x :> sub) where
type SiteSpec ctx (QueryParams sym x :> sub) = [x] -> SiteSpec ctx sub
buildSite :: ([x] -> SiteSpec ctx sub) -> Site ctx
buildSite f = buildSite @ctx @sub $ f []
{-# INLINABLE buildSite #-}
instance Disembodied ctx sub
=> Disembodied ctx (QueryFlag sym :> sub) where
type SiteSpec ctx (QueryFlag sym :> sub) = Bool -> SiteSpec ctx sub
buildSite :: (Bool -> SiteSpec ctx sub) -> Site ctx
buildSite f = buildSite @ctx @sub $ f False
{-# INLINABLE buildSite #-}
instance Disembodied ctx (f '[HTML] (Html m a)) where
type SiteSpec ctx (f '[HTML] (Html m a)) = ctx -> Html m a
buildSite :: (ctx -> Html m a) -> Site ctx
buildSite = SIndex
{-# INLINABLE buildSite #-}
instance Disembodied ctx (View m a) where
type SiteSpec ctx (View m a) = ctx -> Html m a
buildSite :: (ctx -> Html m a) -> Site ctx
buildSite = SIndex
{-# INLINABLE buildSite #-}
writeSite
:: forall layout ctx. Disembodied ctx layout
=> FilePath
-> ctx
-> SiteSpec ctx layout
-> IO ()
writeSite fs ctx layout = go fs $ buildSite @ctx @layout layout where
go :: FilePath -> Site ctx -> IO ()
go curr (SIndex page) = T.writeFile (curr </> "index" <.> "html") . renderStatic $ page ctx
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 site) = do
createDirectoryIfMissing False (curr </> path)
go (curr </> path) site