markup-4.1.0: src/Data/Markup/Library.hs

{-# LANGUAGE
    FlexibleContexts
  , FlexibleInstances
  , OverloadedStrings
  , UndecidableInstances
  , ExtendedDefaultRules
  , MultiParamTypeClasses
  #-}

-- |
-- Module      :  Data.Markup.Library
-- Copyright   :  (c) Athan L. Clark
-- License     :  MIT
--
-- Maintainer  :  Athan L. Clark <athan.clark@gmail.com>
-- Stability   :  experimental
-- Portability :  GHC
--
-- This module enumerates the expected behavior for each type of asset to be
-- deployed.

module Data.Markup.Library where

import           Data.Markup.Class (Deploy (deploy))
import           Data.Markup.Types (Inline (..), Remote (..), Locally (..))

import           Data.Url (MonadUrl (locUrl, pathUrl), RelativeUrlT, GroundedUrlT, AbsoluteUrlT)
import           Data.URI (printURI)
import           Path (Path, Abs, Rel)
import           Path.Extended (Location)

import qualified Lucid                       as L
import qualified Text.Blaze.Html5            as H
import qualified Text.Blaze.Html5.Attributes as A
import qualified Text.Blaze.Internal         as HI
import qualified Clay                        as C

import qualified Data.Text                   as T
import qualified Data.Text.Lazy              as LT
import           Control.Monad.Trans (MonadTrans (lift))


data Image        = Image        deriving (Show, Eq)
data JavaScript   = JavaScript   deriving (Show, Eq)
data Css          = Css          deriving (Show, Eq)
data WebComponent = WebComponent deriving (Show, Eq)


-- Images

-- Remote

linkedImageLucid :: Monad m => T.Text -> L.HtmlT m ()
linkedImageLucid link =
  L.img_ [L.src_ link]

instance ( Monad m
         ) => Deploy Image Remote T.Text (L.HtmlT m) where
  deploy Image Remote = linkedImageLucid

instance ( Monad m
         , MonadUrl Abs t (AbsoluteUrlT m)
         ) => Deploy Image Remote (Path Abs t) (L.HtmlT (AbsoluteUrlT m)) where
  deploy Image Remote i = do
    link <- lift (pathUrl i)
    linkedImageLucid (printURI link)

instance ( Monad m
         , MonadUrl Abs t (AbsoluteUrlT m)
         ) => Deploy Image Remote (Location Abs t) (L.HtmlT (AbsoluteUrlT m)) where
  deploy Image Remote i = do
    link <- lift (locUrl i)
    linkedImageLucid (printURI link)


-- Local

instance ( Monad m
         ) => Deploy Image Locally T.Text (L.HtmlT m) where
  deploy Image Locally = linkedImageLucid

instance ( Monad m
         , MonadUrl Abs t (GroundedUrlT m)
         ) => Deploy Image Locally (Path Abs t) (L.HtmlT (GroundedUrlT m)) where
  deploy Image Locally i = do
    link <- lift (pathUrl i)
    linkedImageLucid (printURI link)

instance ( Monad m
         , MonadUrl Rel t (RelativeUrlT m)
         ) => Deploy Image Locally (Path Rel t) (L.HtmlT (RelativeUrlT m)) where
  deploy Image Locally i = do
    link <- lift (pathUrl i)
    linkedImageLucid (printURI link)

instance ( Monad m
         , MonadUrl Abs t (GroundedUrlT m)
         ) => Deploy Image Locally (Location Abs t) (L.HtmlT (GroundedUrlT m)) where
  deploy Image Locally i = do
    link <- lift (locUrl i)
    linkedImageLucid (printURI link)

instance ( Monad m
         , MonadUrl Rel t (RelativeUrlT m)
         ) => Deploy Image Locally (Location Rel t) (L.HtmlT (RelativeUrlT m)) where
  deploy Image Locally i = do
    link <- lift (locUrl i)
    linkedImageLucid (printURI link)


-- Blaze

-- Remote

linkedImageBlaze :: T.Text -> HI.MarkupM ()
linkedImageBlaze link =
  H.img H.! A.src (H.toValue link)

instance Deploy Image Remote T.Text HI.MarkupM where
  deploy Image Remote = linkedImageBlaze

instance ( MonadUrl Abs t (AbsoluteUrlT HI.MarkupM)
         ) => Deploy Image Remote (Path Abs t) (AbsoluteUrlT HI.MarkupM) where
  deploy Image Remote i = do
    link <- pathUrl i
    lift (linkedImageBlaze (printURI link))

instance ( MonadUrl Abs t (AbsoluteUrlT HI.MarkupM)
         ) => Deploy Image Remote (Location Abs t) (AbsoluteUrlT HI.MarkupM) where
  deploy Image Remote i = do
    link <- locUrl i
    lift (linkedImageBlaze (printURI link))


-- Local

instance Deploy Image Locally T.Text HI.MarkupM where
  deploy Image Locally = linkedImageBlaze

instance ( MonadUrl Abs t (GroundedUrlT HI.MarkupM)
         ) => Deploy Image Locally (Path Abs t) (GroundedUrlT HI.MarkupM) where
  deploy Image Locally i = do
    link <- pathUrl i
    lift (linkedImageBlaze (printURI link))

instance ( MonadUrl Rel t (RelativeUrlT HI.MarkupM)
         ) => Deploy Image Locally (Path Rel t) (RelativeUrlT HI.MarkupM) where
  deploy Image Locally i = do
    link <- pathUrl i
    lift (linkedImageBlaze (printURI link))

instance ( MonadUrl Abs t (GroundedUrlT HI.MarkupM)
         ) => Deploy Image Locally (Location Abs t) (GroundedUrlT HI.MarkupM) where
  deploy Image Locally i = do
    link <- locUrl i
    lift (linkedImageBlaze (printURI link))

instance ( MonadUrl Rel t (RelativeUrlT HI.MarkupM)
         ) => Deploy Image Locally (Location Rel t) (RelativeUrlT HI.MarkupM) where
  deploy Image Locally i = do
    link <- locUrl i
    lift (linkedImageBlaze (printURI link))


-- JavaScript

-- Remote

linkedJavaScriptLucid :: Monad m => T.Text -> L.HtmlT m ()
linkedJavaScriptLucid link =
  L.script_ [L.src_ link] ("" :: T.Text)

instance ( Monad m
         ) => Deploy JavaScript Remote T.Text (L.HtmlT m) where
  deploy JavaScript Remote = linkedJavaScriptLucid

instance ( Monad m
         , MonadUrl Abs t (AbsoluteUrlT m)
         ) => Deploy JavaScript Remote (Path Abs t) (L.HtmlT (AbsoluteUrlT m)) where
  deploy JavaScript Remote i = do
    link <- lift (pathUrl i)
    linkedJavaScriptLucid (printURI link)

instance ( Monad m
         , MonadUrl Abs t (AbsoluteUrlT m)
         ) => Deploy JavaScript Remote (Location Abs t) (L.HtmlT (AbsoluteUrlT m)) where
  deploy JavaScript Remote i = do
    link <- lift (locUrl i)
    linkedJavaScriptLucid (printURI link)


-- Local

instance ( Monad m
         ) => Deploy JavaScript Locally T.Text (L.HtmlT m) where
  deploy JavaScript Locally = linkedJavaScriptLucid

instance ( Monad m
         , MonadUrl Abs t (GroundedUrlT m)
         ) => Deploy JavaScript Locally (Path Abs t) (L.HtmlT (GroundedUrlT m)) where
  deploy JavaScript Locally i = do
    link <- lift (pathUrl i)
    linkedJavaScriptLucid (printURI link)

instance ( Monad m
         , MonadUrl Rel t (RelativeUrlT m)
         ) => Deploy JavaScript Locally (Path Rel t) (L.HtmlT (RelativeUrlT m)) where
  deploy JavaScript Locally i = do
    link <- lift (pathUrl i)
    linkedJavaScriptLucid (printURI link)

instance ( Monad m
         , MonadUrl Abs t (GroundedUrlT m)
         ) => Deploy JavaScript Locally (Location Abs t) (L.HtmlT (GroundedUrlT m)) where
  deploy JavaScript Locally i = do
    link <- lift (locUrl i)
    linkedJavaScriptLucid (printURI link)

instance ( Monad m
         , MonadUrl Rel t (RelativeUrlT m)
         ) => Deploy JavaScript Locally (Location Rel t) (L.HtmlT (RelativeUrlT m)) where
  deploy JavaScript Locally i = do
    link <- lift (locUrl i)
    linkedJavaScriptLucid (printURI link)

-- Inline

instance ( Monad m
         ) => Deploy JavaScript Inline T.Text (L.HtmlT m) where
  deploy JavaScript Inline =
    L.script_ []

instance ( Monad m
         ) => Deploy JavaScript Inline LT.Text (L.HtmlT m) where
  deploy JavaScript Inline =
    L.script_ []


-- Blaze

-- Remote

linkedJavaScriptBlaze :: T.Text -> HI.MarkupM ()
linkedJavaScriptBlaze link =
  H.script (H.toHtml ("" :: T.Text)) H.! A.src (H.toValue link)

instance Deploy JavaScript Remote T.Text HI.MarkupM where
  deploy JavaScript Remote = linkedJavaScriptBlaze

instance ( MonadUrl Abs t (AbsoluteUrlT HI.MarkupM)
         ) => Deploy JavaScript Remote (Path Abs t) (AbsoluteUrlT HI.MarkupM) where
  deploy JavaScript Remote i = do
    link <- pathUrl i
    lift (linkedJavaScriptBlaze (printURI link))

instance ( MonadUrl Abs t (AbsoluteUrlT HI.MarkupM)
         ) => Deploy JavaScript Remote (Location Abs t) (AbsoluteUrlT HI.MarkupM) where
  deploy JavaScript Remote i = do
    link <- locUrl i
    lift (linkedJavaScriptBlaze (printURI link))


-- Local

instance Deploy JavaScript Locally T.Text HI.MarkupM where
  deploy JavaScript Locally = linkedJavaScriptBlaze

instance ( MonadUrl Abs t (GroundedUrlT HI.MarkupM)
         ) => Deploy JavaScript Locally (Path Abs t) (GroundedUrlT HI.MarkupM) where
  deploy JavaScript Locally i = do
    link <- pathUrl i
    lift (linkedJavaScriptBlaze (printURI link))

instance ( MonadUrl Rel t (RelativeUrlT HI.MarkupM)
         ) => Deploy JavaScript Locally (Path Rel t) (RelativeUrlT HI.MarkupM) where
  deploy JavaScript Locally i = do
    link <- pathUrl i
    lift (linkedJavaScriptBlaze (printURI link))

instance ( MonadUrl Abs t (GroundedUrlT HI.MarkupM)
         ) => Deploy JavaScript Locally (Location Abs t) (GroundedUrlT HI.MarkupM) where
  deploy JavaScript Locally i = do
    link <- locUrl i
    lift (linkedJavaScriptBlaze (printURI link))

instance ( MonadUrl Rel t (RelativeUrlT HI.MarkupM)
         ) => Deploy JavaScript Locally (Location Rel t) (RelativeUrlT HI.MarkupM) where
  deploy JavaScript Locally i = do
    link <- locUrl i
    lift (linkedJavaScriptBlaze (printURI link))

-- Inline

instance Deploy JavaScript Inline T.Text HI.MarkupM where
  deploy JavaScript Inline i =
    H.script (H.toHtml i)

instance Deploy JavaScript Inline LT.Text HI.MarkupM where
  deploy JavaScript Inline i =
    H.script (H.toHtml i)


-- Css

-- Remote

linkedCssLucid :: Monad m => T.Text -> L.HtmlT m ()
linkedCssLucid link =
  L.link_ [ L.rel_ "stylesheet"
          , L.type_ "text/css"
          , L.href_ link
          ]

instance ( Monad m
         ) => Deploy Css Remote T.Text (L.HtmlT m) where
  deploy Css Remote = linkedCssLucid

instance ( Monad m
         , MonadUrl Abs t (AbsoluteUrlT m)
         ) => Deploy Css Remote (Path Abs t) (L.HtmlT (AbsoluteUrlT m)) where
  deploy Css Remote i = do
    link <- lift (pathUrl i)
    linkedCssLucid (printURI link)

instance ( Monad m
         , MonadUrl Abs t (AbsoluteUrlT m)
         ) => Deploy Css Remote (Location Abs t) (L.HtmlT (AbsoluteUrlT m)) where
  deploy Css Remote i = do
    link <- lift (locUrl i)
    linkedCssLucid (printURI link)


-- Local

instance ( Monad m
         ) => Deploy Css Locally T.Text (L.HtmlT m) where
  deploy Css Locally = linkedCssLucid

instance ( Monad m
         , MonadUrl Abs t (GroundedUrlT m)
         ) => Deploy Css Locally (Path Abs t) (L.HtmlT (GroundedUrlT m)) where
  deploy Css Locally i = do
    link <- lift (pathUrl i)
    linkedCssLucid (printURI link)

instance ( Monad m
         , MonadUrl Rel t (RelativeUrlT m)
         ) => Deploy Css Locally (Path Rel t) (L.HtmlT (RelativeUrlT m)) where
  deploy Css Locally i = do
    link <- lift (pathUrl i)
    linkedCssLucid (printURI link)

instance ( Monad m
         , MonadUrl Abs t (GroundedUrlT m)
         ) => Deploy Css Locally (Location Abs t) (L.HtmlT (GroundedUrlT m)) where
  deploy Css Locally i = do
    link <- lift (locUrl i)
    linkedCssLucid (printURI link)

instance ( Monad m
         , MonadUrl Rel t (RelativeUrlT m)
         ) => Deploy Css Locally (Location Rel t) (L.HtmlT (RelativeUrlT m)) where
  deploy Css Locally i = do
    link <- lift (locUrl i)
    linkedCssLucid (printURI link)

-- Inline

instance ( Monad m
         ) => Deploy Css Inline T.Text (L.HtmlT m) where
  deploy Css Inline =
    L.style_ []

instance ( Monad m
         ) => Deploy Css Inline LT.Text (L.HtmlT m) where
  deploy Css Inline =
    L.style_ []

instance ( Monad m
         ) => Deploy Css Inline C.Css (L.HtmlT m) where
  deploy Css Inline i =
    L.style_ [] (C.render i)


-- Blaze

-- Remote

linkedCssBlaze :: T.Text -> HI.MarkupM ()
linkedCssBlaze link =
  H.link H.! A.rel "stylesheet"
         H.! A.type_ "text/css"
         H.! A.href (H.toValue link)

instance Deploy Css Remote T.Text HI.MarkupM where
  deploy Css Remote = linkedCssBlaze

instance ( MonadUrl Abs t (AbsoluteUrlT HI.MarkupM)
         ) => Deploy Css Remote (Path Abs t) (AbsoluteUrlT HI.MarkupM) where
  deploy Css Remote i = do
    link <- pathUrl i
    lift (linkedCssBlaze (printURI link))

instance ( MonadUrl Abs t (AbsoluteUrlT HI.MarkupM)
         ) => Deploy Css Remote (Location Abs t) (AbsoluteUrlT HI.MarkupM) where
  deploy Css Remote i = do
    link <- locUrl i
    lift (linkedCssBlaze (printURI link))


-- Local

instance Deploy Css Locally T.Text HI.MarkupM where
  deploy Css Locally = linkedCssBlaze

instance ( MonadUrl Abs t (GroundedUrlT HI.MarkupM)
         ) => Deploy Css Locally (Path Abs t) (GroundedUrlT HI.MarkupM) where
  deploy Css Locally i = do
    link <- pathUrl i
    lift (linkedCssBlaze (printURI link))

instance ( MonadUrl Rel t (RelativeUrlT HI.MarkupM)
         ) => Deploy Css Locally (Path Rel t) (RelativeUrlT HI.MarkupM) where
  deploy Css Locally i = do
    link <- pathUrl i
    lift (linkedCssBlaze (printURI link))

instance ( MonadUrl Abs t (GroundedUrlT HI.MarkupM)
         ) => Deploy Css Locally (Location Abs t) (GroundedUrlT HI.MarkupM) where
  deploy Css Locally i = do
    link <- locUrl i
    lift (linkedCssBlaze (printURI link))

instance ( MonadUrl Rel t (RelativeUrlT HI.MarkupM)
         ) => Deploy Css Locally (Location Rel t) (RelativeUrlT HI.MarkupM) where
  deploy Css Locally i = do
    link <- locUrl i
    lift (linkedCssBlaze (printURI link))

-- Inline

instance Deploy Css Inline T.Text HI.MarkupM where
  deploy Css Inline i =
    H.style (H.toHtml i)

instance Deploy Css Inline LT.Text HI.MarkupM where
  deploy Css Inline i =
    H.style (H.toHtml i)

instance Deploy Css Inline C.Css HI.MarkupM where
  deploy Css Inline i =
    H.style (H.toHtml (C.render i))


-- WebComponent instances

-- Remote

linkedWebComponentLucid :: Monad m => T.Text -> L.HtmlT m ()
linkedWebComponentLucid link =
  L.link_ [ L.rel_ "import"
          , L.href_ link
          ]

instance ( Monad m
         ) => Deploy WebComponent Remote T.Text (L.HtmlT m) where
  deploy WebComponent Remote = linkedWebComponentLucid

instance ( Monad m
         , MonadUrl Abs t (AbsoluteUrlT m)
         ) => Deploy WebComponent Remote (Path Abs t) (L.HtmlT (AbsoluteUrlT m)) where
  deploy WebComponent Remote i = do
    link <- lift (pathUrl i)
    linkedWebComponentLucid (printURI link)

instance ( Monad m
         , MonadUrl Abs t (AbsoluteUrlT m)
         ) => Deploy WebComponent Remote (Location Abs t) (L.HtmlT (AbsoluteUrlT m)) where
  deploy WebComponent Remote i = do
    link <- lift (locUrl i)
    linkedWebComponentLucid (printURI link)

-- instance ( Monad m
--          , MonadUrl Abs t (AbsoluteUrlT m)
--          , MonadThrow (AbsoluteUrlT m)
--          , ToLocation s Abs t
--          ) => Deploy WebComponent s (L.HtmlT (AbsoluteUrlT m)) where
--   deploy WebComponent Remote i = do
--     i' <- lift (toLocation i)
--     link <- lift (locUrl i')
--     linkedWebComponentLucid (printURI link)


-- Local

instance ( Monad m
         ) => Deploy WebComponent Locally T.Text (L.HtmlT m) where
  deploy WebComponent Locally = linkedWebComponentLucid

instance ( Monad m
         , MonadUrl Abs t (GroundedUrlT m)
         ) => Deploy WebComponent Locally (Path Abs t) (L.HtmlT (GroundedUrlT m)) where
  deploy WebComponent Locally i = do
    link <- lift (pathUrl i)
    linkedWebComponentLucid (printURI link)

instance ( Monad m
         , MonadUrl Rel t (RelativeUrlT m)
         ) => Deploy WebComponent Locally (Path Rel t) (L.HtmlT (RelativeUrlT m)) where
  deploy WebComponent Locally i = do
    link <- lift (pathUrl i)
    linkedWebComponentLucid (printURI link)

instance ( Monad m
         , MonadUrl Abs t (GroundedUrlT m)
         ) => Deploy WebComponent Locally (Location Abs t) (L.HtmlT (GroundedUrlT m)) where
  deploy WebComponent Locally i = do
    link <- lift (locUrl i)
    linkedWebComponentLucid (printURI link)

instance ( Monad m
         , MonadUrl Rel t (RelativeUrlT m)
         ) => Deploy WebComponent Locally (Location Rel t) (L.HtmlT (RelativeUrlT m)) where
  deploy WebComponent Locally i = do
    link <- lift (locUrl i)
    linkedWebComponentLucid (printURI link)

-- instance ( Monad m
--          , MonadUrl Abs t (GroundedUrlT m)
--          , MonadThrow (GroundedUrlT m)
--          , ToLocation s Abs t
--          ) => Deploy WebComponent Locally s (L.HtmlT (GroundedUrlT m)) where
--   deploy WebComponent Locally i = do
--     i' <- lift (toLocation i)
--     link <- lift (locUrl i')
--     linkedWebComponentLucid (printURI link)
--
-- instance ( Monad m
--          , MonadUrl Rel t (RelativeUrlT m)
--          , MonadThrow (RelativeUrlT m)
--          , ToLocation s Rel t
--          ) => Deploy WebComponent Locally s (L.HtmlT (RelativeUrlT m)) where
--   deploy WebComponent Locally i = do
--     i' <- lift (toLocation i)
--     link <- lift (locUrl i')
--     linkedWebComponentLucid (printURI link)

-- Blaze

-- Remote

linkedWebComponentBlaze :: T.Text -> HI.MarkupM ()
linkedWebComponentBlaze link =
  H.link H.! A.rel "import"
         H.! A.href (H.toValue link)

instance Deploy WebComponent Remote T.Text HI.MarkupM where
  deploy WebComponent Remote = linkedWebComponentBlaze

instance ( MonadUrl Abs t (AbsoluteUrlT HI.MarkupM)
         ) => Deploy WebComponent Remote (Path Abs t) (AbsoluteUrlT HI.MarkupM) where
  deploy WebComponent Remote i = do
    link <- pathUrl i
    lift (linkedWebComponentBlaze (printURI link))

instance ( MonadUrl Abs t (AbsoluteUrlT HI.MarkupM)
         ) => Deploy WebComponent Remote (Location Abs t) (AbsoluteUrlT HI.MarkupM) where
  deploy WebComponent Remote i = do
    link <- locUrl i
    lift (linkedWebComponentBlaze (printURI link))


-- Local

instance Deploy WebComponent Locally T.Text HI.MarkupM where
  deploy WebComponent Locally = linkedWebComponentBlaze

instance ( MonadUrl Abs t (GroundedUrlT HI.MarkupM)
         ) => Deploy WebComponent Locally (Path Abs t) (GroundedUrlT HI.MarkupM) where
  deploy WebComponent Locally i = do
    link <- pathUrl i
    lift (linkedWebComponentBlaze (printURI link))

instance ( MonadUrl Rel t (RelativeUrlT HI.MarkupM)
         ) => Deploy WebComponent Locally (Path Rel t) (RelativeUrlT HI.MarkupM) where
  deploy WebComponent Locally i = do
    link <- pathUrl i
    lift (linkedWebComponentBlaze (printURI link))

instance ( MonadUrl Abs t (GroundedUrlT HI.MarkupM)
         ) => Deploy WebComponent Locally (Location Abs t) (GroundedUrlT HI.MarkupM) where
  deploy WebComponent Locally i = do
    link <- locUrl i
    lift (linkedWebComponentBlaze (printURI link))

instance ( MonadUrl Rel t (RelativeUrlT HI.MarkupM)
         ) => Deploy WebComponent Locally (Location Rel t) (RelativeUrlT HI.MarkupM) where
  deploy WebComponent Locally i = do
    link <- locUrl i
    lift (linkedWebComponentBlaze (printURI link))