owickstrom/.gitignore

## .gitignore
.stack-work

## README.md

      
    Raw
  

              README.md
            
          
    Compile-time checking globally loaded scripts for Yesod

Yesod has powerful features for including dynamic scripts, using widgets. In
many cases this is exactly what I want, but in some, I want scripts to be
loaded globally in all pages.
The primary motivation for globally loaded scripts, appearing in the <head>
element in all pages, is for using something like PJAX, possibly together with
HTML5 custom elements. I'd like to declare a number of custom elements, and
only use HTML markup in the widgets using the custom elements, i.e. no dynamic
script tags added to the page by the widgets. By doing so, the PJAX-variant
could be much simpler, not having to inject scripts in the page sent in the
PJAX response. All custom elements' Javascript would already be loaded, and the
DOM insertions of the widget markup would trigger the scripts to run.
A complication with these global scripts are that all possibly needed scripts
have to be loaded. For this to be statically known, at compile-time, the
globally loaded scripts need to represented in types somehow. This
demonstration is a dumbed down version of Yesod, just to illustrate the design,
and some machinery for associating global scripts with an application
(Foundation type).

  
## global-scripts.cabal
name:                global-scripts
version:             0.1.0.0
homepage:            https://gist.github.com/owickstrom/91615af9d0de89cf2107efaa57a8b019
author:              Oskar Wickström
maintainer:          oskar.wickstrom@gmail.com
copyright:           2017 Oskar Wickström
category:            Web
build-type:          Simple
cabal-version:       >=1.10
extra-source-files:  README.md

executable global-scripts
  hs-source-dirs:      .
  main-is:             Main.hs
  default-language:    Haskell2010
  build-depends:       base >= 4.7 && < 5
                     , protolude
                     , text
                     , mtl

## Main.hs
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE TypeOperators     #-}

module Main where

import           Protolude

import           Control.Monad.Reader hiding ((<>))
import           Control.Monad.Writer hiding ((<>))
import           Data.String

-- YESOD LIGHT

type Widget app a = WriterT Text (Reader app) a

respond :: Text -> Widget app ()
respond = tell

runWidget :: app -> Widget app a -> (a, Text)
runWidget app = flip runReader app . runWriterT

-- GLOBAL SCRIPTS LIBRARY

-- | For applications (Yesod foundation types) that that have globally
-- loaded scripts.
class GlobalScripts app where
  type Scripts app :: [*]
  globalScripts :: app -> HList (Scripts app)

-- | Specialized result type used in checking if a global script is
-- available. Used instead of type-level boolean for better error
-- messages.
data ScriptAvailability where
  ScriptNotAvailable :: k -> ScriptAvailability
  ScriptAvailable :: ScriptAvailability

-- | Checks if a global script is available in the list.
type family HasScript (x :: *) (xs :: [*]) where
  HasScript x '[] = 'ScriptNotAvailable x
  HasScript x (x ': xs) = 'ScriptAvailable
  HasScript x (a ': xs) = HasScript x xs

-- | Asserts that the application has a given script globally loaded.
requireGlobalScript
  :: forall script app.
     (HasScript script (Scripts app) ~ 'ScriptAvailable)
  => Proxy script -> Widget app ()
requireGlobalScript script = return ()

-- | Get the source for a single script.
class ScriptSource s where
  scriptSource :: s -> Text

-- | Get the sources for a multiple scripts.
class ScriptSources s where
  scriptSources :: s -> [Text]

-- | HList could perhaps come from some library...
data HList xs where
  Nil :: HList '[]
  Cons :: x -> HList xs -> HList (x ': xs)

instance (ScriptSource x, ScriptSources (HList xs)) =>
         ScriptSources (HList (x ': xs)) where
  scriptSources (Cons x xs) =
    scriptSource x : scriptSources xs

instance ScriptSources (HList '[]) where
  scriptSources Nil = []

-- | Runs a widget, returning all script tags and page content as
-- 'Text'. This would look a bit different in a real implementation.
runHandler
  :: (GlobalScripts app, ScriptSources (HList (Scripts app)))
  => app -> Widget app () -> Text
runHandler app w =
  scriptSources (globalScripts app)
  & map scriptTag
  & mconcat
  & (<> pc)
  where
    scriptTag src =
      mconcat [ "<script src=\"", src, "\"></script>"]
    (_, pc) = runWidget app w


-- This is the part the user would write. Perhaps not the 'JQuery' definition.

-- SCRIPTS

data JQuery
  = JQuerySlimMinified
  | JQueryUncompressed

instance ScriptSource JQuery where
  scriptSource =
    \case
        JQueryUncompressed -> "https://code.jquery.com/jquery-3.2.1.js"
        JQuerySlimMinified -> "https://code.jquery.com/jquery-3.2.1.slim.min.js"

newtype MyCustomElements = MyCustomElements { root :: Text }

instance ScriptSource MyCustomElements where
  -- | Here would be nice to refer to a StaticR route.
  scriptSource customElements =
    root customElements <> "/my-custom-elements.js"

-- APP

newtype TestApp = TestApp { appDevelopment :: Bool }

instance GlobalScripts TestApp where
  -- | We specify what scripts are globally available in our
  -- application.
  type Scripts TestApp = '[ JQuery, MyCustomElements]
  -- | We provide specific values for the global scripts. Different
  -- versions of jQuery might be loaded at runtime, but the Widgets
  -- don't care as long as it's the JQuery type.
  globalScripts TestApp {..} =
    Cons jquery (Cons (MyCustomElements customElementsRoot) Nil)
    where
      jquery =
        if appDevelopment
          then JQueryUncompressed
          else JQuerySlimMinified
      customElementsRoot =
        if appDevelopment
          then ""
          else "https://my-site.example.com"

-- WIDGETS
--
-- Here we can require scripts be loaded globally, and this be sure at
-- compile-time they are.

myWidget1 :: Widget TestApp ()
myWidget1 = do
  requireGlobalScript (Proxy @JQuery)
  respond "<p>Hello, I use jQuery!</p>"

myWidget2 :: Widget TestApp ()
myWidget2 = do
  requireGlobalScript (Proxy @JQuery)
  respond "<p>I also depend on Query.</p>"

myWidget3 :: Widget TestApp ()
myWidget3 = do
  requireGlobalScript (Proxy @MyCustomElements)
  respond "<my-custom-element>Here we go!</my-custom-element>"

myHandler :: Widget TestApp ()
myHandler = do
  myWidget1
  myWidget2
  myWidget3

-- MAIN

main :: IO ()
main = do
  let app = TestApp {appDevelopment = False}
  putStrLn $ runHandler app myHandler

-- PROGRAM OUTPUT
--
-- *Main> :main
-- <script src="https://code.jquery.com/jquery-3.2.1.slim.min.js"></script><script src="https://my-site.example.com/my-custom-elements.js"></script><p>Hello, I use jQuery!</p><p>I also depend on Query.</p><my-custom-element>Here we go!</my-custom-element>

## Setup.hs
import Distribution.Simple
main = defaultMain

## stack.yaml
resolver: lts-9.2
packages:
- '.'
extra-deps: []
flags: {}
extra-package-dbs: []
	name: global-scripts
	version: 0.1.0.0
	homepage: https://gist.github.com/owickstrom/91615af9d0de89cf2107efaa57a8b019
	author: Oskar Wickström
	maintainer: oskar.wickstrom@gmail.com
	copyright: 2017 Oskar Wickström
	category: Web
	build-type: Simple
	cabal-version: >=1.10
	extra-source-files: README.md

	executable global-scripts
	hs-source-dirs: .
	main-is: Main.hs
	default-language: Haskell2010
	build-depends: base >= 4.7 && < 5
	, protolude
	, text
	, mtl
	{-# LANGUAGE DataKinds #-}
	{-# LANGUAGE FlexibleContexts #-}
	{-# LANGUAGE FlexibleInstances #-}
	{-# LANGUAGE GADTs #-}
	{-# LANGUAGE LambdaCase #-}
	{-# LANGUAGE NoImplicitPrelude #-}
	{-# LANGUAGE OverloadedStrings #-}
	{-# LANGUAGE RankNTypes #-}
	{-# LANGUAGE RecordWildCards #-}
	{-# LANGUAGE TypeApplications #-}
	{-# LANGUAGE TypeFamilies #-}
	{-# LANGUAGE TypeOperators #-}

	module Main where

	import Protolude

	import Control.Monad.Reader hiding ((<>))
	import Control.Monad.Writer hiding ((<>))
	import Data.String

	-- YESOD LIGHT

	type Widget app a = WriterT Text (Reader app) a

	respond :: Text -> Widget app ()
	respond = tell

	runWidget :: app -> Widget app a -> (a, Text)
	runWidget app = flip runReader app . runWriterT

	-- GLOBAL SCRIPTS LIBRARY

	-- \| For applications (Yesod foundation types) that that have globally
	-- loaded scripts.
	class GlobalScripts app where
	type Scripts app :: [*]
	globalScripts :: app -> HList (Scripts app)

	-- \| Specialized result type used in checking if a global script is
	-- available. Used instead of type-level boolean for better error
	-- messages.
	data ScriptAvailability where
	ScriptNotAvailable :: k -> ScriptAvailability
	ScriptAvailable :: ScriptAvailability

	-- \| Checks if a global script is available in the list.
	type family HasScript (x :: ) (xs :: []) where
	HasScript x '[] = 'ScriptNotAvailable x
	HasScript x (x ': xs) = 'ScriptAvailable
	HasScript x (a ': xs) = HasScript x xs

	-- \| Asserts that the application has a given script globally loaded.
	requireGlobalScript
	:: forall script app.
	(HasScript script (Scripts app) ~ 'ScriptAvailable)
	=> Proxy script -> Widget app ()
	requireGlobalScript script = return ()

	-- \| Get the source for a single script.
	class ScriptSource s where
	scriptSource :: s -> Text

	-- \| Get the sources for a multiple scripts.
	class ScriptSources s where
	scriptSources :: s -> [Text]

	-- \| HList could perhaps come from some library...
	data HList xs where
	Nil :: HList '[]
	Cons :: x -> HList xs -> HList (x ': xs)

	instance (ScriptSource x, ScriptSources (HList xs)) =>
	ScriptSources (HList (x ': xs)) where
	scriptSources (Cons x xs) =
	scriptSource x : scriptSources xs

	instance ScriptSources (HList '[]) where
	scriptSources Nil = []

	-- \| Runs a widget, returning all script tags and page content as
	-- 'Text'. This would look a bit different in a real implementation.
	runHandler
	:: (GlobalScripts app, ScriptSources (HList (Scripts app)))
	=> app -> Widget app () -> Text
	runHandler app w =
	scriptSources (globalScripts app)
	& map scriptTag
	& mconcat
	& (<> pc)
	where
	scriptTag src =
	mconcat [ "<script src=\"", src, "\"></script>"]
	(_, pc) = runWidget app w


	-- This is the part the user would write. Perhaps not the 'JQuery' definition.

	-- SCRIPTS

	data JQuery
	= JQuerySlimMinified
	\| JQueryUncompressed

	instance ScriptSource JQuery where
	scriptSource =
	\case
	JQueryUncompressed -> "https://code.jquery.com/jquery-3.2.1.js"
	JQuerySlimMinified -> "https://code.jquery.com/jquery-3.2.1.slim.min.js"

	newtype MyCustomElements = MyCustomElements { root :: Text }

	instance ScriptSource MyCustomElements where
	-- \| Here would be nice to refer to a StaticR route.
	scriptSource customElements =
	root customElements <> "/my-custom-elements.js"

	-- APP

	newtype TestApp = TestApp { appDevelopment :: Bool }

	instance GlobalScripts TestApp where
	-- \| We specify what scripts are globally available in our
	-- application.
	type Scripts TestApp = '[ JQuery, MyCustomElements]
	-- \| We provide specific values for the global scripts. Different
	-- versions of jQuery might be loaded at runtime, but the Widgets
	-- don't care as long as it's the JQuery type.
	globalScripts TestApp {..} =
	Cons jquery (Cons (MyCustomElements customElementsRoot) Nil)
	where
	jquery =
	if appDevelopment
	then JQueryUncompressed
	else JQuerySlimMinified
	customElementsRoot =
	if appDevelopment
	then ""
	else "https://my-site.example.com"

	-- WIDGETS
	--
	-- Here we can require scripts be loaded globally, and this be sure at
	-- compile-time they are.

	myWidget1 :: Widget TestApp ()
	myWidget1 = do
	requireGlobalScript (Proxy @JQuery)
	respond "<p>Hello, I use jQuery!</p>"

	myWidget2 :: Widget TestApp ()
	myWidget2 = do
	requireGlobalScript (Proxy @JQuery)
	respond "<p>I also depend on Query.</p>"

	myWidget3 :: Widget TestApp ()
	myWidget3 = do
	requireGlobalScript (Proxy @MyCustomElements)
	respond "<my-custom-element>Here we go!</my-custom-element>"

	myHandler :: Widget TestApp ()
	myHandler = do
	myWidget1
	myWidget2
	myWidget3

	-- MAIN

	main :: IO ()
	main = do
	let app = TestApp {appDevelopment = False}
	putStrLn $ runHandler app myHandler

	-- PROGRAM OUTPUT
	--
	-- *Main> :main
	-- <script src="https://code.jquery.com/jquery-3.2.1.slim.min.js"></script><script src="https://my-site.example.com/my-custom-elements.js"></script><p>Hello, I use jQuery!</p><p>I also depend on Query.</p><my-custom-element>Here we go!</my-custom-element>
	resolver: lts-9.2
	packages:
	- '.'
	extra-deps: []
	flags: {}
	extra-package-dbs: []