-- |
-- Module : Presentation.Yeamer
-- Copyright : (c) Justus Sagemüller 2017
-- License : GPL v3
--
-- Maintainer : (@) jsag $ hvl.no
-- Stability : experimental
-- Portability : portable
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Presentation.Yeamer ( Presentation
-- * Running a presentation
, yeamer
-- * Primitives
, staticContent, tweakContent, serverSide
-- ** Maths
, ($<>), maths
-- ** Media content
, imageFromFile, mediaFromFile, imageFromFileSupplier
-- ** Arbitrary file serving
, useFile, useFileSupplier
-- ** Code / plaintext
, verbatim, plaintext, verbatimWithin
-- ** Haskell values
, InteractiveShow(..)
-- ** Interactive parameters
, inputBox, dropdownSelect, feedback_
-- * Structure / composition
, addHeading, (======), discardResult
, module Data.Monoid
, module Data.Semigroup.Numbered
, (→│)
, (↘──)
, (│←)
, (──↖)
, (→│←)
, (↘──↖)
, (→│→)
, (↘──↘)
-- * CSS
, divClass, divClasses, spanClass, (#%), styling, Css
-- * Server configuration
, yeamer'
, YeamerServerConfig
-- | Default port is 14910
, yeamerTcpPort
-- * Internals
, IPresentation
) where
import Yesod hiding (get)
import Yesod.Form.Jquery
import qualified Data.Text as Txt
import qualified Data.Text.Lazy as Txt (toStrict)
import qualified Data.Text.Encoding as Txt
import Data.Text (Text)
import Data.String (IsString (..))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Char8 as BC8
import Flat (Flat, flat, unflat)
import qualified Data.Aeson as JSON
import qualified Text.Blaze.Html5 as HTM
import qualified Text.Blaze.Html5.Attributes as HTM
import qualified Text.Blaze.Html.Renderer.Text as HTMText
import Presentation.Yeamer.Internal.Progress
import Presentation.Yeamer.Internal.PrPathStepCompression
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Vector as Arr
import Presentation.Yeamer.Internal.Grid
import Text.Cassius (cassius, Css)
import Text.Julius (rawJS, Javascript, renderJavascript)
import Yesod.Static (Static, static, base64md5)
import Yesod.EmbeddedStatic
import qualified Language.Javascript.JQuery as JQuery
import Language.Haskell.TH.Syntax ( Exp(LitE, AppE, VarE, ConE)
, Lit(StringL), Name, runIO )
import GHC.TypeLits (KnownSymbol, symbolVal)
import GHC.Stack (HasCallStack)
import Data.Int (Int64, Int32, Int16)
import Language.Haskell.TH.Quote
import qualified CAS.Dumb.Symbols as TMM
import qualified CAS.Dumb.Tree as TMM
import qualified Math.LaTeX.Prelude as TMM
import Text.LaTeX (LaTeX)
import qualified Text.LaTeX as LaTeX
import qualified Text.TeXMath as MathML
import qualified Text.XML.Light as XML
import Text.Printf
import Data.List (intercalate)
import Data.Foldable (fold)
import Data.Traversable.Redundancy (rmRedundancy)
import Control.Monad.Trans.Writer.JSONable
import Control.Monad.Trans.List
import Control.Monad.Trans.State
import Control.Monad.Trans.Reader
import Control.Monad.Catch (MonadThrow(..), Exception(..))
import Data.These
import Data.These.Lens
import Data.Either (partitionEithers)
import qualified Data.Semigroup as SG
import Data.Semigroup.Numbered
import Data.Monoid
import Data.Maybe
import Data.Functor.Identity
import Control.Monad
import Control.Arrow (first, second, (&&&))
import Control.Applicative
import Data.Typeable(Typeable)
import Data.Function ((&))
import Data.Tuple (swap)
import Data.Proxy
import Data.Default.Class
import System.FilePath ( takeFileName, takeExtension, takeBaseName, dropExtension
, (<.>), (>) )
import System.IO.Error (catchIOError, isAlreadyExistsError)
import System.Directory ( doesPathExist, canonicalizePath, removeFile
, createDirectoryIfMissing, renameFile
#if MIN_VERSION_directory(1,3,1)
, createFileLink, pathIsSymbolicLink, getSymbolicLinkTarget
#endif
)
#if !MIN_VERSION_directory(1,3,1)
import System.Posix.Files (createSymbolicLink, readSymbolicLink)
#endif
import System.IO.Temp
import GHC.Generics
import Lens.Micro
import Lens.Micro.TH
import Data.Bifunctor (bimap)
#if !MIN_VERSION_directory(1,3,1)
createFileLink = createSymbolicLink
getSymbolicLinkTarget = readSymbolicLink
pathIsSymbolicLink _ = pure True
#endif
#if !MIN_VERSION_flat(0,4,0)
instance (Flat a) => Flat (Identity a)
#endif
type Sessionable = Flat
data SessionableWitness a where
SessionableWitness :: Sessionable a => SessionableWitness a
data EncapsulableWitness t where
EncapsulableWitness :: (∀ r . Sessionable r => SessionableWitness (t r))
-> EncapsulableWitness t
data Container t where
WithHeading :: Html -> Container Identity
ManualCSSClasses :: Container (WriterT HTMChunkK [])
GriddedBlocks :: Container Gridded
CustomEncapsulation :: EncapsulableWitness t -> (t Html -> Html) -> Container t
data HTMChunkK = HTMDiv {_hchunkCSSClass::Text} | HTMSpan {_hchunkCSSClass::Text}
deriving (Generic, Eq, Ord)
instance JSON.FromJSON HTMChunkK
instance JSON.ToJSON HTMChunkK
instance Flat HTMChunkK
makeLenses ''HTMChunkK
data IPresentation m r where
StaticContent :: Html -> IPresentation m ()
DynamicContent :: m Html -> IPresentation m ()
TweakableInput :: (Sessionable x, JSON.FromJSON x)
=> Maybe x -- Default value as the cell's output
-> ( PrPath -> ( Text -- The “final leaf” of the DOM path
, Maybe x -> -- An already stored value
( PresProgress -> JavascriptUrl (Route PresentationServer)
, Html )
))
-> IPresentation m (Maybe x)
Resultless :: IPresentation m r -> IPresentation m ()
Styling :: [Css] -> IPresentation m r -> IPresentation m r
Encaps :: (Traversable t, Sessionable r, Sessionable rf, Sessionable (t ()))
=> Container t -> (t r -> rf)
-> t (IPresentation m r) -> IPresentation m rf
Pure :: r -> IPresentation m r
Deterministic :: (r -> Maybe s) -> IPresentation m r -> IPresentation m s
Interactive :: Sessionable r
=> IPresentation m () -> m r -> IPresentation m r
Feedback :: Sessionable r
=> (Maybe r -> IPresentation m r) -> IPresentation m r
Dependent :: Sessionable x
=> IPresentation m x -> (x -> IPresentation m r)
-> IPresentation m (Either x r)
instance (r ~ ()) => IsString (IPresentation m r) where
fromString = StaticContent . fromString
type Presentation = IPresentation IO ()
data PresentationServer = PresentationServer {
presentationToShow :: Presentation
, getStatic :: EmbeddedStatic
, getPseudostatic :: Static
}
mkEmbeddedStatic False "myStatic" . pure . embedFileAt "jquery.js" =<< runIO JQuery.file
pStatDir :: FilePath
pStatDir = ".pseudo-static-content"
mkYesod "PresentationServer" [parseRoutes|
/ HomeR GET
/p/#PresProgress ExactPositionR GET
/changeposition/#PresProgress/#PositionChange ChPosR GET
/setvalue/#PresProgress/#PrPath/#ValueToSet SetValR GET
/reset ResetR GET
/static StaticR EmbeddedStatic getStatic
/pseudostatic PStaticR Static getPseudostatic
|]
instance Yesod PresentationServer where
addStaticContent = embedStaticContent getStatic StaticR Right
approot = ApprootRelative
instance YesodJquery PresentationServer
preprocPres :: IPresentation m r -> IPresentation m r
preprocPres (StaticContent c) = StaticContent c
preprocPres (DynamicContent c) = DynamicContent c
preprocPres (TweakableInput defV frm) = TweakableInput defV frm
preprocPres (Resultless p) = Resultless $ preprocPres p
preprocPres (Styling s p) = Styling s $ preprocPres p
preprocPres (Encaps (WithHeading h) ff p) = Encaps (WithHeading h) ff $ preprocPres<$>p
preprocPres (Encaps ManualCSSClasses ff p) = Encaps ManualCSSClasses ff $ preprocPres<$>p
preprocPres (Encaps (CustomEncapsulation (EncapsulableWitness w) f) ff p)
= Encaps (CustomEncapsulation (EncapsulableWitness w) f) ff $ preprocPres<$>p
preprocPres (Encaps GriddedBlocks ff p)
= Styling grids
. fmap ff
. divClass gridClass
. Encaps ManualCSSClasses (fst . backonstruct . map (first (read . Txt.unpack . _hchunkCSSClass) . swap)
. runWriterT)
$ preprocPres <$> layouted
where (GridLayout w h prelayed, backonstruct) = layoutGridP p
layouted = WriterT $ swap . first (HTMDiv . ("autogrid-range_"<>) . idc)
. snd <$> prelayed
gridRep :: [[Text]]
gridRep = foldr fill (replicate h $ replicate w ".") prelayed
where fill (GridRange xb xe yb ye, (i, _)) field
= yPre ++ [ xPre ++ (idc i<$xRel) ++ xPost
| xAll <- yRel
, let (xPre, (xRel, xPost)) = splitAt xb xAll
& second (splitAt $ xe-xb) ] ++ yPost
where (yPre, (yRel, yPost)) = splitAt yb field
& second (splitAt $ ye-yb)
idc i
| c <- toEnum $ fromEnum 'a' + i
, c <= 'z' = Txt.singleton c
| c <- toEnum $ fromEnum '㐀' + i
, c <= '鿋' = Txt.singleton c
| otherwise = error "Too many grid cells to display."
gridClass = "autogrid_"<>Txt.intercalate "-" (Txt.concat<$>gridRep)
grids = [lucius|
div.#{gridClass} {
display: grid;
grid-template-areas: #{areas}
}
|]()
: [ [lucius| div .#{divid} { grid-area: #{ist} } |]()
| (_, (i, _)) <- prelayed
, let ist = idc i
divid = "autogrid-range_" <> ist ]
where areas = fold ["\""<>Txt.intercalate " " line<>"\" "
| line <- gridRep ]
preprocPres (Pure x) = Pure x
preprocPres (Deterministic f p) = Deterministic f $ preprocPres p
preprocPres (Interactive p a) = Interactive (preprocPres p) a
preprocPres (Feedback f) = Feedback $ preprocPres . f
preprocPres (Dependent d o) = Dependent (preprocPres d) (preprocPres<$>o)
isInline :: IPresentation m a -> Bool
isInline (StaticContent _) = True
isInline (DynamicContent _) = True
isInline (TweakableInput _ _) = False
isInline (Encaps ManualCSSClasses _ (WriterT qs)) = all (\(_,i) -> case i of
HTMSpan _ -> True
HTMDiv _ -> False ) qs
isInline (Encaps _ _ _) = False
isInline (Styling _ q) = isInline q
isInline (Interactive q _) = isInline q
isInline (Feedback f) = False
isInline (Resultless q) = isInline q
isInline (Dependent q _) = isInline q
isInline (Deterministic _ q) = isInline q
isInline (Pure _) = True
getHomeR :: Handler Html
getHomeR = redirect . ExactPositionR $ assemblePresProgress mempty
getExactPositionR :: PresProgress -> Handler Html
getExactPositionR pPosition = do
PresentationServer presentation _ _ <- getYesod
defaultLayout $ do
addScript $ StaticR jquery_js
slideChoice <- (`runReaderT`pPosition)
$ chooseSlide "" defaultChoiceName "" Nothing Nothing presentation
(`here`slideChoice) $ \slide -> do
contents <- liftIO $ go 0 slide
toWidget contents
return ()
where chooseSlide :: PrPath -> (Text->PrPath) -> Text -> Maybe PrPath -> Maybe PrPath
-> IPresentation IO r
-> ReaderT PresProgress
(WidgetT PresentationServer IO) (These Presentation r)
chooseSlide _ _ "" Nothing Nothing (StaticContent conts)
= pure $ These (StaticContent conts) ()
chooseSlide _ _ "" Nothing Nothing (DynamicContent conts)
= pure $ These (DynamicContent conts) ()
chooseSlide path choiceName pdiv Nothing Nothing (TweakableInput defV frm) = do
let (leafNm, interactor) = frm path
fullPath = path<>leafNm
storedValue <- lookupProgress fullPath
let (action, contents) = interactor storedValue
toWidget . action =<< ask
pure $ case (defV, storedValue) of
(Nothing, Nothing) -> This $ StaticContent contents
(_, Just r) -> These (StaticContent contents) (Just r)
(Just r, _) -> These (StaticContent contents) (Just r)
chooseSlide path choiceName "" Nothing Nothing (Styling sty conts)
= mapM_ toWidget sty
>> chooseSlide path choiceName "" Nothing Nothing conts
chooseSlide path choiceName "" Nothing Nothing (Encaps f ff conts)
= postGather <$> cellwise f
where postGather sq = case sequence sq of
That p's -> That $ ff p's
This _ -> This $ Encaps f (const())
$ fmap (maybe mempty id . (^?here)) sq
These _ p's -> (`These`ff p's) $ Encaps f (const())
$ fmap (maybe mempty id . (^?here)) sq
cellwise ManualCSSClasses
| WriterT contsL <- conts
= WriterT <$> (`traverse`contsL) `id` \(cell,i) ->
(,i) <$> chooseSlide (path<>case i of
HTMDiv c -> " div."<>c
HTMSpan c -> " span."<>c
) choiceName "" Nothing Nothing cell
cellwise _ = traverse (chooseSlide path choiceName "" Nothing Nothing) conts
chooseSlide path choiceName "" Nothing Nothing (Interactive conts followAction) = do
purity <- chooseSlide path choiceName "" Nothing Nothing conts
case purity ^? here of
Just pres -> pure . This $ discardResult pres
Nothing -> That <$> liftIO followAction
chooseSlide path choiceName pdiv bwd fwd (Feedback conts) = do
prefetch <- chooseSlide path choiceName pdiv bwd fwd $ conts Nothing
case prefetch ^? there of
Just v -> chooseSlide path choiceName pdiv bwd fwd . conts $ Just v
Nothing -> pure prefetch
chooseSlide path choiceName "" Nothing Nothing (Resultless conts) = do
purity <- chooseSlide path choiceName "" Nothing Nothing conts
case purity ^? here of
Just pres -> pure . (`These`()) $ discardResult pres
Nothing -> pure $ That ()
chooseSlide path choiceName "" Nothing Nothing (Deterministic f conts)
= chooseSlide path choiceName "" Nothing Nothing conts
<&> \case
This pres -> This pres
That res -> case f res of
Just q -> That q
-- The `Nothing` case should not be possible here, because
-- `Deterministic` cannot be directly accessed by the user, and can
-- only yield `Nothing` is part of `oRDependent`, which guarantees
-- that there is content. (Not entirely sure about all this, TODO
-- making it rigorous.)
These pres res -> case f res of
Just q -> These pres q
Nothing -> This pres
chooseSlide path choiceName pdiv bwd fwd (Dependent def opt) = do
let progPath = path<>" span."<>choiceName pdiv
positionCh <- lookupProgress progPath
case positionCh of
Nothing -> do
-- liftIO . putStrLn $ "Not enter '"++Txt.unpack progPath++"'"
purity <- chooseSlide path choiceName (pdiv<>"0") bwd (Just progPath) def
case purity of
This pres -> pure . This $ discardResult pres
That x -> do
pPosition' <- setProgress progPath x `execStateT` pPosition
redirect $ ExactPositionR pPosition'
These pres x -> pure . These (discardResult pres) $ Left x
Just x -> fmap (fmap Right)
. chooseSlide path choiceName (pdiv<>"1") (Just progPath) fwd
$ opt x
chooseSlide path choiceName pdiv bwd fwd pres
| isJust bwd || isJust fwd = do
let thisChoice = choiceName pdiv
newPath = (path<>" span."<>thisChoice)
[revertPossible, progressPossible]
= maybe "false" (const "true") <$> [bwd,fwd] :: [Text]
[previous,next] = maybe "null" id <$> [bwd, fwd]
toWidget [julius|
$("#{rawJS newPath}").click(function(e){
if (e.ctrlKey && #{rawJS revertPossible}) {
isRevert = true;
pChanger =
"@{ChPosR pPosition (PositionChange previous PositionRevert)}";
} else if (!(e.ctrlKey) && #{rawJS progressPossible}) {
isRevert = false;
pChanger =
"@{ChPosR pPosition (PositionChange next PositionAdvance)}";
} else {
return;
}
e.stopPropagation();
hasErrored = false;
$.ajax({
contentType: "application/json",
processData: false,
url: pChanger,
type: "GET",
dataType: "text",
success: function(newURL, textStatus, jqXHR) {
if (isRevert) {
window.location.replace(newURL);
} else {
window.location.href = newURL;
}
},
error: function(jqXHR, textStatus, errorThrown) {
$("body").css("cursor","not-allowed");
hasErrored = true;
setTimeout(function() {
$("body").css("cursor","auto")}, 500);
}
});
setTimeout(function() {
if (!hasErrored) {$("body").css("cursor","wait")}
}, 150);
})
|]
(here %~ spanClass thisChoice)
<$> chooseSlide newPath (disambiguateChoiceName choiceName)
"" Nothing Nothing pres
chooseSlide _ _ _ _ _ (Pure x) = pure $ That x
chooseSlide _ _ _ _ _ pres
= error $ "Cannot display "++outerConstructorName pres
go :: Monad m => Int -> IPresentation m r -> m Html
go _ (StaticContent conts) = pure conts
go _ (DynamicContent conts) = conts
go _ (Pure _) = error $ "Error: impossible to render a slide of an empty presentation."
go _ (Dependent _ _) = error $ "Internal error: un-selected Dependent option while rendering to HTML."
go lvl (Deterministic _ conts) = go lvl conts
go lvl (Resultless conts) = go lvl conts
go lvl (Interactive conts _) = go lvl conts
go lvl (Styling sty conts) = go lvl conts
go lvl (Encaps (WithHeading h) ff conts)
= let lvl' = min 6 $ lvl + 1
hh = [HTM.h1, HTM.h2, HTM.h3, HTM.h4, HTM.h5, HTM.h6]!!lvl
in go lvl' $ Encaps (CustomEncapsulation (EncapsulableWitness SessionableWitness)
$ \(Identity contsr)
-> HTM.div HTM.! HTM.class_ "headed-container"
$ hh h <> contsr
) ff conts
go lvl (Encaps ManualCSSClasses ff conts)
= go lvl $ Encaps (CustomEncapsulation (EncapsulableWitness SessionableWitness) $ \(WriterT contsrs)
-> foldMap (\(q,i) -> case i of
HTMDiv c -> [hamlet|
#{q} |]()
HTMSpan c -> [hamlet| #{q} |]())
$ contsrs
) ff conts
where withSupclass c
| Just _ <- Txt.stripPrefix "autogrid_" c
= "autogrid "<>c
| otherwise = c
go lvl (Encaps (CustomEncapsulation (EncapsulableWitness _) f) _ conts)
= fmap f . forM conts $ go lvl
go _ p = error $ outerConstructorName p <> " cannot be rendered."
preferThis :: These a b -> Either a b
preferThis (This a) = Left a
preferThis (That b) = Right b
preferThis (These a _) = Left a
hchunkFor :: Text -> IPresentation m r -> HTMChunkK
hchunkFor t p | isInline p = HTMSpan t
| otherwise = HTMDiv t
instance (Monad m, Monoid r, Sessionable r) => SG.Semigroup (IPresentation m r) where
StaticContent c <> StaticContent d = StaticContent $ c<>d
DynamicContent c <> DynamicContent d = DynamicContent $ liftA2 (<>) c d
StaticContent c <> DynamicContent d = DynamicContent $ (c<>)<$>d
DynamicContent c <> StaticContent d = DynamicContent $ (<>d)<$>c
Encaps ManualCSSClasses ff₀ (WriterT elems₀) <> Encaps ManualCSSClasses ff₁ (WriterT elems₁)
= Encaps ManualCSSClasses ff' . WriterT . disambiguate
$ map (first $ fmap Left) elems₀ ++ map (first $ fmap Right) elems₁
where disambiguate = go 0 Map.empty
where go _ _ [] = []
go i occupied ((q,c):qs)
| Txt.null (_hchunkCSSClass c) || c`Map.member`occupied
= let c' = c & hchunkCSSClass .~ Txt.pack ("anonymousCell-"++show i)
in go (i+1) occupied (( Encaps ManualCSSClasses (fst . head . runWriterT) $ WriterT [(q,c)]
, c' ):qs)
| otherwise
= (q,c) : go (i+1) (Map.insert c () occupied) qs
ff' (WriterT l) = case partitionEithers
$ map ( \(d,r)->case d of Left d'->Left (d',r)
Right d'->Right (d',r) ) l of
(l₀,l₁) -> ff₀ (WriterT l₀)<>ff₁ (WriterT l₁)
Resultless (Encaps ManualCSSClasses _ ps) <> Resultless (Encaps ManualCSSClasses _ qs)
= Resultless $ Encaps ManualCSSClasses id (discardResult<$>ps)
SG.<> Encaps ManualCSSClasses id (discardResult<$>qs)
Resultless p@(Encaps ManualCSSClasses _ _) <> c
= Resultless p <> Resultless (Encaps ManualCSSClasses id $ WriterT [(c,hchunkFor""c)])
c <> Resultless p@(Encaps ManualCSSClasses _ _)
= Resultless (Encaps ManualCSSClasses id $ WriterT [(c,hchunkFor""c)]) <> Resultless p
p <> q = Encaps ManualCSSClasses fold $ WriterT
[(p, hchunkFor"anonymousCell-0"p), (q, hchunkFor"anonymousCell-1"q)]
instance ∀ m . Monad m => Monoid (IPresentation m ()) where
mappend = (SG.<>)
mempty = Resultless $ Encaps ManualCSSClasses id
(WriterT [] :: WriterT HTMChunkK [] (IPresentation m ()))
infix 6 →│
(→│) :: (Sessionable a)
=> IPresentation m a -> IPresentation m b -> IPresentation m a
l→│r = fmap (\(GridDivisions [[GridRegion (Just a), GridRegion Nothing]]) -> a)
. Encaps GriddedBlocks id
$ GridDivisions [GridRegion<$>[ Just<$>l, const Nothing<$>r ]]
infix 5 ↘──
(↘──) :: (Sessionable a)
=> IPresentation m a -> IPresentation m b -> IPresentation m a
l↘──r = fmap (\(GridDivisions [[GridRegion (Just a)], [GridRegion Nothing]]) -> a)
. Encaps GriddedBlocks id
$ GridDivisions [[GridRegion $ Just<$>l], [GridRegion $ const Nothing<$>r]]
infix 6 │←
(│←) :: (Sessionable b)
=> IPresentation m a -> IPresentation m b -> IPresentation m b
l│←r = fmap (\(GridDivisions [[GridRegion Nothing, GridRegion (Just b)]]) -> b)
. Encaps GriddedBlocks id
$ GridDivisions [GridRegion<$>[ const Nothing<$>l, Just<$>r ]]
infix 5 ──↖
(──↖) :: (Sessionable b)
=> IPresentation m a -> IPresentation m b -> IPresentation m b
l──↖r = fmap (\(GridDivisions [[GridRegion Nothing, GridRegion (Just b)]]) -> b)
. Encaps GriddedBlocks id
$ GridDivisions [[GridRegion $ const Nothing<$>l], [GridRegion $ Just<$>r]]
infix 6 →│→
(→│→) :: (Sessionable a, Monad m)
=> IPresentation m a -> (a -> IPresentation m ()) -> IPresentation m a
l→│→r = Feedback $ \aFbq -> l →│ case aFbq of
Just a -> r a
Nothing -> mempty
infix 5 ↘──↘
(↘──↘) :: (Sessionable a, Monad m)
=> IPresentation m a -> (a -> IPresentation m ()) -> IPresentation m a
l↘──↘r = Feedback $ \aFbq -> l ↘── case aFbq of
Just a -> r a
Nothing -> mempty
infix 6 →│←
(→│←) :: (Sessionable a, Sessionable b)
=> IPresentation m a -> IPresentation m b -> IPresentation m (a,b)
l→│←r = fmap (\(GridDivisions [[GridRegion (Left a), GridRegion (Right b)]])
-> (a,b))
. Encaps GriddedBlocks id
$ GridDivisions [GridRegion<$>[Left<$>l, Right<$>r]]
infix 5 ↘──↖
(↘──↖) :: (Sessionable a, Sessionable b)
=> IPresentation m a -> IPresentation m b -> IPresentation m (a,b)
l↘──↖r = fmap (\(GridDivisions [[GridRegion (Left a)], [GridRegion (Right b)]])
-> (a,b))
. Encaps GriddedBlocks id
$ GridDivisions [[GridRegion $ Left<$>l], [GridRegion $ Right<$>r]]
instance ∀ m . SemigroupNo 0 (IPresentation m ()) where
sappendN _ (Resultless (Encaps GriddedBlocks _ l))
(Resultless (Encaps GriddedBlocks _ r))
= Resultless . Encaps GriddedBlocks id $ (discardResult<$>l) │ (discardResult<$>r)
sappendN _ l@(Resultless (Encaps GriddedBlocks _ _)) r
= l │ Resultless (Encaps GriddedBlocks id $ pure r)
sappendN _ l r
= Resultless (Encaps GriddedBlocks id $ pure l) │ r
instance ∀ m . SemigroupNo 1 (IPresentation m ()) where
sappendN _ (Resultless (Encaps GriddedBlocks _ t))
(Resultless (Encaps GriddedBlocks _ b))
= Resultless . Encaps GriddedBlocks id $ (discardResult<$>t) ── (discardResult<$>b)
sappendN _ t@(Resultless (Encaps GriddedBlocks _ _)) b
= t ── Resultless (Encaps GriddedBlocks id $ pure b)
sappendN _ t b
= Resultless (Encaps GriddedBlocks id $ pure t) ── b
outerConstructorName :: IPresentation m r -> String
outerConstructorName (StaticContent _) = "StaticContent"
outerConstructorName (DynamicContent _) = "DynamicContent"
outerConstructorName (TweakableInput _ _) = "TweakableInput"
outerConstructorName (Resultless _) = "Resultless"
outerConstructorName (Styling _ _) = "Styling"
outerConstructorName (Encaps (WithHeading _) _ _) = "Encaps WithHeading"
outerConstructorName (Encaps (CustomEncapsulation _ _) _ _) = "Encaps CustomEncapsulation"
outerConstructorName (Encaps ManualCSSClasses _ _) = "Encaps ManualCSSClasses"
outerConstructorName (Encaps GriddedBlocks _ _) = "Encaps GriddedBlocks"
outerConstructorName (Pure _) = "Pure"
outerConstructorName (Deterministic _ _) = "Deterministic"
outerConstructorName (Interactive _ _) = "Interactive"
outerConstructorName (Dependent _ _) = "Dependent"
discardResult :: IPresentation m r -> IPresentation m ()
discardResult (StaticContent c) = StaticContent c
discardResult (DynamicContent c) = DynamicContent c
discardResult (Resultless p) = Resultless p
discardResult p = Resultless p
feedback_ :: Sessionable a => (Maybe a -> IPresentation m a) -> IPresentation m ()
feedback_ = discardResult . Feedback
-- | Run a monadic action and use the result in the presentation.
-- Note that the action may not be re-run even if it depends to other
-- values chosen at another point in the presentation, so use with care.
serverSide :: Sessionable a => m a -> IPresentation m a
serverSide = Interactive (pure ())
instance Functor (IPresentation m) where
fmap f (Deterministic g q) = Deterministic (fmap f . g) q
fmap f (Pure x) = Pure $ f x
fmap f q = Deterministic (Just . f) q
instance Applicative (IPresentation m) where
pure = Pure
Pure f <*> x = fmap f x
f <*> Pure x = fmap ($ x) f
fs<*>xs = ap fs xs
onlyRight :: IPresentation m (Either a b) -> IPresentation m b
onlyRight = Deterministic $ \case
Left _ -> Nothing
Right y -> Just y
oRDependent :: Flat x
=> IPresentation m x -> (x -> IPresentation m r) -> IPresentation m r
oRDependent a b = onlyRight $ Dependent a b
instance ∀ m . Monad (IPresentation m) where
return = pure
StaticContent c >>= f = oRDependent (StaticContent c) f
DynamicContent c >>= f = oRDependent (DynamicContent c) f
TweakableInput defV frm >>= f = oRDependent (TweakableInput defV frm) f
Resultless p >>= f = oRDependent (Resultless p) f
Feedback p >>= f = oRDependent (Feedback p) f
Styling _ (Pure x) >>= f = f x
Styling s (StaticContent c) >>= f = oRDependent (Styling s (StaticContent c)) f
Styling s (DynamicContent c) >>= f = oRDependent (Styling s (DynamicContent c)) f
Styling s (Resultless c) >>= f = oRDependent (Styling s (Resultless c)) f
Styling s (Styling s' x) >>= f = Styling (s++s') x >>= f
Styling s (Encaps (WithHeading h) ff x) >>= f
= oRDependent (Styling s (Encaps (WithHeading h) ff x)) f
Styling s (Encaps ManualCSSClasses ff x) >>= f
= oRDependent (Styling s (Encaps ManualCSSClasses ff x)) f
Styling s (Deterministic g x) >>= f = Deterministic g (Styling s x) >>= f
Styling s (Interactive p o) >>= f = oRDependent (Interactive (Styling s p) o) f
Styling s (Dependent p g) >>= f
= oRDependent (Styling s p) $ \x -> Styling s (g x) >>= f . Right
Encaps (WithHeading h) ff p >>= f = oRDependent (Encaps (WithHeading h) ff p) f
Encaps ManualCSSClasses ff ps >>= f = oRDependent (Encaps ManualCSSClasses ff ps) f
Encaps (CustomEncapsulation (EncapsulableWitness w') e') ff' ps' >>= f'
= bindCustEncaps w' e' ff' ps' f'
where bindCustEncaps :: ∀ a b t r tr
. (Sessionable r, Sessionable tr, Traversable t, Sessionable (t ()))
=> (∀ r' . Sessionable r' => SessionableWitness (t r'))
-> (t Html -> Html)
-> (t r -> tr)
-> t (IPresentation m r)
-> (tr -> IPresentation m b)
-> IPresentation m b
bindCustEncaps w e ff ps f
= case w :: SessionableWitness (t r) of
SessionableWitness
-> oRDependent (Encaps (CustomEncapsulation (EncapsulableWitness w) e) ff ps) f
Pure x >>= f = f x
Deterministic g p >>= f = onlyRight $
p >>= \x -> case g x of
Just y -> Right <$> f y
Nothing -> Left <$> p
Interactive p q >>= f = oRDependent (Interactive p q) f
Dependent p g >>= f = oRDependent p $ g >=> f . Right
o >> Interactive (Pure _) q = Interactive (discardResult o) q
o >> Pure x = fmap (const x) o
o >> n = o >>= const n
infixr 6 ======
-- | Infix synonym of 'addHeading'. Intended to be used
-- in @do@ blocks, for headings of presentation slides.
(======) :: Sessionable r => Html -> IPresentation m r -> IPresentation m r
(======) = addHeading
addHeading :: Sessionable r => Html -> IPresentation m r -> IPresentation m r
addHeading h = Encaps (WithHeading h) runIdentity . Identity
divClass :: Sessionable r => Text -> IPresentation m r -> IPresentation m r
divClass cn = Encaps ManualCSSClasses (fst . head . runWriterT) . WriterT . pure . (,HTMDiv cn)
spanClass :: Sessionable r => Text -> IPresentation m r -> IPresentation m r
spanClass cn = Encaps ManualCSSClasses (fst . head . runWriterT) . WriterT . pure . (,HTMSpan cn)
divClasses :: Sessionable r => [(Text, IPresentation m r)] -> IPresentation m r
divClasses cns = Encaps ManualCSSClasses (fst . head . runWriterT) $ WriterT [ (content,HTMDiv cn)
| (cn,content) <- cns ]
infix 8 #%
-- | Assign this content a CSS class attribute. If the content is inline, this will
-- be a @@, else a @
@.
(#%) :: Sessionable r => Text -> IPresentation m r -> IPresentation m r
c#%q
| isInline q = spanClass c q
| otherwise = divClass c q
styling :: Css -> IPresentation m r -> IPresentation m r
styling s (Styling s' a) = Styling (s:s') a
styling s a = Styling [s] a
staticContent :: Monoid r => Html -> IPresentation m r
staticContent = fmap (const mempty) . StaticContent
tweakContent :: Sessionable r => (Html -> Html) -> IPresentation m r -> IPresentation m r
tweakContent f = Encaps (CustomEncapsulation (EncapsulableWitness SessionableWitness)
$ f . runIdentity) runIdentity
. Identity
type JSCode url0 = (url0 -> [(Text,Text)] -> Text) -> Javascript
class Sessionable i => Inputtable i where
inputElemHtml :: i -- ^ Current value
-> String -- ^ id in the DOM
-> Html
inputElemJSRead :: String -- ^ id in the DOM
-> Javascript -- ^ Expression that reads out the value
inputElemJSRead inputElId
= [julius| $("#{rawJS inputElId}").val() |](\_ _ -> mempty)
instance Inputtable Int where
inputElemHtml currentVal hashedId = [hamlet|
|]()
instance Inputtable Double where
inputElemHtml currentVal hashedId = [hamlet|
|]()
instance Inputtable String where
inputElemHtml currentVal hashedId = [hamlet|
|]()
inputElemJSRead inputElId
= [julius| JSON.stringify($("#{rawJS inputElId}").val()) |](\_ _ -> mempty)
inputBox :: ∀ i m . (Inputtable i, JSON.FromJSON i) => i -> IPresentation m i
inputBox iDef = fmap (maybe iDef id) . TweakableInput (Just iDef) $ \path ->
let hashedId = base64md5 . BSL.fromStrict $ Txt.encodeUtf8 path
inputElId = "input#"++hashedId
in ( leafNm
, \prevInp ->
let currentVal = case prevInp of
Nothing -> iDef
Just v -> v
valueReader = rawJS . renderJavascript $ inputElemJSRead @i inputElId
in ( \pPosition -> [julius|
$("#{rawJS inputElId}").click(function(e){
e.stopPropagation();
})
$("#{rawJS inputElId}").change(function(e){
currentVal = #{valueReader}
pChanger =
"@{SetValR pPosition path NoValGiven}".slice(0, -1)
// The slice hack removes the `NoValGiven`, to
// be replaced with the actual value:
+ currentVal;
e.stopPropagation();
hasErrored = false;
$.ajax({
contentType: "application/json",
processData: false,
url: pChanger,
type: "GET",
dataType: "text",
success: function(newURL, textStatus, jqXHR) {
window.location.href = newURL;
},
error: function(jqXHR, textStatus, errorThrown) {
$("body").css("cursor","not-allowed");
hasErrored = true;
setTimeout(function() {
$("body").css("cursor","auto")}, 500);
}
});
setTimeout(function() {
if (!hasErrored) {$("body").css("cursor","wait")}
}, 150);
})
|]
, inputElemHtml currentVal hashedId
) )
where leafNm = " input"
dropdownSelect :: ∀ a m . (a -> String) -> [a] -> Int -> IPresentation m a
dropdownSelect valShow options iDef
| iDef>=0 && iDef
let hashedId = base64md5 . BSL.fromStrict $ Txt.encodeUtf8 path
selectElId = "select#"++hashedId
in ( leafNm
, \prevInp ->
let currentIndex = case prevInp of
Nothing -> iDef
Just i -> i
in ( \pPosition -> [julius|
$("#{rawJS selectElId}").click(function(e){
e.stopPropagation();
})
$("#{rawJS selectElId}").change(function(e){
currentVal = $("#{rawJS selectElId}").val()
pChanger =
"@{SetValR pPosition path NoValGiven}".slice(0, -1)
// The slice hack removes the `NoValGiven`, to
// be replaced with the actual value:
+ currentVal;
e.stopPropagation();
hasErrored = false;
$.ajax({
contentType: "application/json",
processData: false,
url: pChanger,
type: "GET",
dataType: "text",
success: function(newURL, textStatus, jqXHR) {
window.location.href = newURL;
},
error: function(jqXHR, textStatus, errorThrown) {
$("body").css("cursor","not-allowed");
hasErrored = true;
setTimeout(function() {
$("body").css("cursor","auto")}, 500);
}
});
setTimeout(function() {
if (!hasErrored) {$("body").css("cursor","wait")}
}, 150);
})
|]
, let ixedOptions = zip [0..] $ valShow<$>options
isCurrentIndex = (==currentIndex)
in [hamlet|