yeamer 0.1.0.5 → 0.1.1.0
raw patch · 9 files changed
+599/−166 lines, 9 filesdep ~TeX-my-mathdep ~flatdep ~texmath
Dependency ranges changed: TeX-my-math, flat, texmath
Files
- Control/Monad/Trans/Writer/JSONable.hs +2/−2
- Data/Traversable/Redundancy.hs +1/−1
- Presentation/Yeamer.hs +456/−138
- Presentation/Yeamer/Internal/Grid.hs +29/−14
- Presentation/Yeamer/Internal/PrPathStepCompression.hs +1/−1
- Presentation/Yeamer/Internal/Progress.hs +42/−3
- Presentation/Yeamer/Maths.hs +1/−1
- test/Main.hs +62/−1
- yeamer.cabal +5/−5
Control/Monad/Trans/Writer/JSONable.hs view
@@ -3,7 +3,7 @@ -- Copyright : (c) Justus Sagemüller 2017 -- License : GPL v3 -- --- Maintainer : (@) jsagemue $ uni-koeln.de+-- Maintainer : (@) jsag $ hvl.no -- Stability : experimental -- Portability : portable -- @@ -17,7 +17,7 @@ module Control.Monad.Trans.Writer.JSONable where import Data.Aeson-import Data.Flat+import Flat import GHC.Generics import Data.Semigroup
Data/Traversable/Redundancy.hs view
@@ -3,7 +3,7 @@ -- Copyright : (c) Justus Sagemüller 2017 -- License : GPL v3 -- --- Maintainer : (@) jsagemue $ uni-koeln.de+-- Maintainer : (@) jsag $ hvl.no -- Stability : experimental -- Portability : portable --
Presentation/Yeamer.hs view
@@ -3,7 +3,7 @@ -- Copyright : (c) Justus Sagemüller 2017 -- License : GPL v3 -- --- Maintainer : (@) jsagemue $ uni-koeln.de+-- Maintainer : (@) jsag $ hvl.no -- Stability : experimental -- Portability : portable -- @@ -20,11 +20,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# 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@@ -39,10 +44,17 @@ , useFile, useFileSupplier -- ** Code / plaintext , verbatim, plaintext, verbatimWithin+ -- ** Haskell values+ , InteractiveShow(..)+ -- ** Interactive parameters+ , inputBox, feedback_ -- * Structure / composition , addHeading, (======), discardResult , module Data.Monoid , module Data.Semigroup.Numbered+ , (→│←)+ , (→│)+ , (→│→) -- * CSS , divClass, divClasses, spanClass, (#%), styling, Css -- * Server configuration@@ -63,7 +75,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Char8 as BC8-import Data.Flat (Flat, flat, unflat)+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@@ -75,14 +87,17 @@ import qualified Data.Vector as Arr import Presentation.Yeamer.Internal.Grid -import Text.Cassius (Css)-import Text.Julius (rawJS)+import Text.Cassius (cassius, Css)+import Text.Julius (rawJS, Javascript) 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@@ -92,6 +107,7 @@ 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)@@ -102,6 +118,7 @@ import Control.Monad.Trans.Reader import Data.These import Data.These.Lens+import Data.Either (partitionEithers) import qualified Data.Semigroup as SG import Data.Semigroup.Numbered import Data.Monoid@@ -113,6 +130,7 @@ import Data.Function ((&)) import Data.Tuple (swap)+import Data.Proxy import Data.Default.Class import System.FilePath ( takeFileName, takeExtension, takeBaseName, dropExtension@@ -166,14 +184,25 @@ data IPresentation m r where StaticContent :: Html -> IPresentation m ()+ TweakableInput :: (Sessionable x, JSON.FromJSON x)+ => Maybe x+ -> ( 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 (t ()))- => Container t -> t (IPresentation m r) -> IPresentation m (t 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 -> 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 r instance (r ~ ()) => IsString (IPresentation m r) where@@ -196,6 +225,7 @@ / 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@@ -207,18 +237,19 @@ preprocPres :: IPresentation m r -> IPresentation m r preprocPres (StaticContent c) = StaticContent 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) p) = Encaps (WithHeading h) $ preprocPres<$>p-preprocPres (Encaps ManualCSSClasses p) = Encaps ManualCSSClasses $ preprocPres<$>p-preprocPres (Encaps (CustomEncapsulation (EncapsulableWitness w) f) p)- = Encaps (CustomEncapsulation (EncapsulableWitness w) f) $ preprocPres<$>p-preprocPres (Encaps GriddedBlocks 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- . fmap (backonstruct . map (first (read . Txt.unpack . _hchunkCSSClass) . swap)+ . Encaps ManualCSSClasses (backonstruct . map (first (read . Txt.unpack . _hchunkCSSClass) . swap) . runWriterT)- . Encaps ManualCSSClasses $ preprocPres <$> layouted where (GridLayout w h prelayed, backonstruct) = layoutGridP p layouted = WriterT $ swap . first (HTMDiv . ("autogrid-range_"<>) . idc)@@ -255,17 +286,20 @@ 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 (Encaps ManualCSSClasses (WriterT qs)) = all (\(_,i) -> case i of+isInline (TweakableInput _ _) = False+isInline (Encaps ManualCSSClasses _ (WriterT qs)) = all (\(_,i) -> case i of HTMSpan _ -> True HTMDiv _ -> False ) qs-isInline (Encaps _ _) = False+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@@ -293,16 +327,26 @@ (WidgetT PresentationServer IO) (These Presentation r) chooseSlide _ _ "" Nothing Nothing (StaticContent conts) = pure $ These (StaticContent 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 conts)+ chooseSlide path choiceName "" Nothing Nothing (Encaps f ff conts) = postGather <$> cellwise f where postGather sq = case sequence sq of- That p's -> That p's- This _ -> This . discardResult $ Encaps f+ That p's -> That $ ff p's+ This _ -> This $ Encaps f (const()) $ fmap (maybe mempty id . (^?here)) sq- These _ p's -> (`These`p's) . discardResult $ Encaps f+ These _ p's -> (`These`ff p's) $ Encaps f (const()) $ fmap (maybe mempty id . (^?here)) sq cellwise ManualCSSClasses | WriterT contsL <- conts@@ -317,6 +361,11 @@ 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@@ -346,43 +395,45 @@ = 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 True)}";- } else if (!(e.ctrlKey) && #{rawJS progressPossible}) {- isRevert = false;- pChanger = "@{ChPosR pPosition (PositionChange next False)}";- } 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);- })- |]+ $("#{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@@ -397,26 +448,26 @@ 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) 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- ) conts- go lvl (Encaps ManualCSSClasses conts)+ ) 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| <div class=#{withSupclass c}> #{q} |]() HTMSpan c -> [hamlet| <span class=#{withSupclass c}> #{q} |]()) $ contsrs- ) conts+ ) ff conts where withSupclass c | Just _ <- Txt.stripPrefix "autogrid_" c = "autogrid "<>c | otherwise = c- go lvl (Encaps (CustomEncapsulation (EncapsulableWitness _) f) conts) = f $ go lvl <$> conts+ go lvl (Encaps (CustomEncapsulation (EncapsulableWitness _) f) _ conts) = f $ go lvl <$> conts go _ p = error $ outerConstructorName p <> " cannot be rendered." @@ -431,59 +482,86 @@ instance (Monoid r, Sessionable r) => SG.Semigroup (IPresentation m r) where StaticContent c <> StaticContent d = StaticContent $ c<>d- Encaps ManualCSSClasses (WriterT elems₀) <> Encaps ManualCSSClasses (WriterT elems₁)- = Encaps ManualCSSClasses . WriterT . disambiguate $ elems₀ ++ elems₁+ 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 (( fmap (fst . head . runWriterT)- . Encaps ManualCSSClasses $ WriterT [(q,c)]+ 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- Resultless (Encaps ManualCSSClasses ps) <> Resultless (Encaps ManualCSSClasses qs)- = Resultless $ Encaps ManualCSSClasses (discardResult<$>ps)- SG.<> Encaps ManualCSSClasses (discardResult<$>qs)- Resultless p@(Encaps ManualCSSClasses _) <> c- = Resultless p <> Resultless (Encaps ManualCSSClasses $ WriterT [(c,hchunkFor""c)])- c <> Resultless p@(Encaps ManualCSSClasses _)- = Resultless (Encaps ManualCSSClasses $ WriterT [(c,hchunkFor""c)]) <> Resultless p- p <> q = fmap fold . Encaps ManualCSSClasses $ WriterT+ 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 . Monoid (IPresentation m ()) where mappend = (SG.<>)- mempty = Resultless $ Encaps ManualCSSClasses+ 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 6 →│→+(→│→) :: (Sessionable a)+ => IPresentation m a -> (a -> IPresentation m ()) -> IPresentation m a+l→│→r = Feedback $ \aFbq -> l →│ case aFbq of+ Just a -> r a+ othing -> 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]]+ instance ∀ m . SemigroupNo 0 (IPresentation m ()) where- sappendN _ (Resultless (Encaps GriddedBlocks l))- (Resultless (Encaps GriddedBlocks r))- = Resultless . Encaps GriddedBlocks $ (discardResult<$>l) │ (discardResult<$>r)- sappendN _ l@(Resultless (Encaps GriddedBlocks _)) r- = l │ Resultless (Encaps GriddedBlocks $ pure r)+ 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 $ pure 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 $ (discardResult<$>t) ── (discardResult<$>b)- sappendN _ t@(Resultless (Encaps GriddedBlocks _)) b- = t ── Resultless (Encaps GriddedBlocks $ pure b)+ 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 $ pure t) ── b+ = Resultless (Encaps GriddedBlocks id $ pure t) ── b outerConstructorName :: IPresentation m r -> String outerConstructorName (StaticContent _) = "StaticContent"+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 (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"@@ -494,6 +572,9 @@ discardResult (Resultless p) = Resultless p discardResult p = Resultless p +feedback_ :: Sessionable a => (Maybe a -> IPresentation m a) -> IPresentation m ()+feedback_ = discardResult . Feedback+ serverSide :: Sessionable a => m a -> IPresentation m a serverSide = Interactive (pure ()) @@ -510,33 +591,36 @@ instance ∀ m . Monad (IPresentation m) where return = pure StaticContent c >>= f = Dependent (StaticContent c) f+ TweakableInput defV frm >>= f = Dependent (TweakableInput defV frm) f Resultless p >>= f = Dependent (Resultless p) f+ Feedback p >>= f = Dependent (Feedback p) f Styling _ (Pure x) >>= f = f x Styling s (StaticContent c) >>= f = Dependent (Styling s (StaticContent c)) f Styling s (Resultless c) >>= f = Dependent (Styling s (Resultless c)) f Styling s (Styling s' x) >>= f = Styling (s++s') x >>= f- Styling s (Encaps (WithHeading h) x) >>= f- = Dependent (Styling s (Encaps (WithHeading h) x)) f- Styling s (Encaps ManualCSSClasses x) >>= f- = Dependent (Styling s (Encaps ManualCSSClasses x)) f+ Styling s (Encaps (WithHeading h) ff x) >>= f+ = Dependent (Styling s (Encaps (WithHeading h) ff x)) f+ Styling s (Encaps ManualCSSClasses ff x) >>= f+ = Dependent (Styling s (Encaps ManualCSSClasses ff x)) f Styling s (Deterministic g x) >>= f = Styling s x >>= f . g Styling s (Interactive p o) >>= f = Dependent (Interactive (Styling s p) o) f Styling s (Dependent p g) >>= f = Dependent (Styling s p) $ Styling s . g >=> f- Encaps (WithHeading h) p >>= f = Dependent (Encaps (WithHeading h) p) f- Encaps ManualCSSClasses ps >>= f = Dependent (Encaps ManualCSSClasses ps) f- Encaps (CustomEncapsulation (EncapsulableWitness w') e') ps' >>= f'- = bindCustEncaps w' e' ps' f'- where bindCustEncaps :: ∀ a b t r- . (Sessionable r, Traversable t, Sessionable (t ()))- => (∀ r' . Sessionable r' => SessionableWitness (t r'))- -> (t Html -> Html)- -> t (IPresentation m r)- -> (t r -> IPresentation m b)- -> IPresentation m b- bindCustEncaps w e ps f+ Encaps (WithHeading h) ff p >>= f = Dependent (Encaps (WithHeading h) ff p) f+ Encaps ManualCSSClasses ff ps >>= f = Dependent (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- -> Dependent (Encaps (CustomEncapsulation (EncapsulableWitness w) e) ps) f+ -> Dependent (Encaps (CustomEncapsulation (EncapsulableWitness w) e) ff ps) f Pure x >>= f = f x Deterministic g p >>= f = p >>= f . g Interactive p q >>= f = Dependent (Interactive p q) f@@ -553,19 +637,16 @@ (======) = addHeading addHeading :: Sessionable r => Html -> IPresentation m r -> IPresentation m r-addHeading h = fmap runIdentity . Encaps (WithHeading h) . Identity+addHeading h = Encaps (WithHeading h) runIdentity . Identity divClass :: Sessionable r => Text -> IPresentation m r -> IPresentation m r-divClass cn = fmap (fst . head . runWriterT)- . Encaps ManualCSSClasses . WriterT . pure . (,HTMDiv cn)+divClass cn = Encaps ManualCSSClasses (fst . head . runWriterT) . WriterT . pure . (,HTMDiv cn) spanClass :: Sessionable r => Text -> IPresentation m r -> IPresentation m r-spanClass cn = fmap (fst . head . runWriterT)- . Encaps ManualCSSClasses . WriterT . pure . (,HTMSpan cn)+spanClass cn = Encaps ManualCSSClasses (fst . head . runWriterT) . WriterT . pure . (,HTMSpan cn) divClasses :: Sessionable r => [(Text, IPresentation m r)] -> IPresentation m r-divClasses cns = fmap (fst . head . runWriterT)- . Encaps ManualCSSClasses $ WriterT [ (content,HTMDiv cn)+divClasses cns = Encaps ManualCSSClasses (fst . head . runWriterT) $ WriterT [ (content,HTMDiv cn) | (cn,content) <- cns ] infix 8 #%@@ -584,11 +665,72 @@ staticContent = fmap (const mempty) . StaticContent tweakContent :: Sessionable r => (Html -> Html) -> IPresentation m r -> IPresentation m r-tweakContent f = fmap runIdentity- . Encaps (CustomEncapsulation (EncapsulableWitness SessionableWitness)- $ f . runIdentity)+tweakContent f = Encaps (CustomEncapsulation (EncapsulableWitness SessionableWitness)+ $ f . runIdentity) runIdentity . Identity +class Sessionable i => Inputtable i where+ inputElemHtml :: i -- ^ Current value+ -> String -- ^ id in the DOM+ -> Html++instance Inputtable Int where+ inputElemHtml currentVal hashedId = [hamlet|+ <input type="number" id="#{hashedId}" value=#{currentVal}>+ |]()++instance Inputtable Double where+ inputElemHtml currentVal hashedId = [hamlet|+ <input type="number" id="#{hashedId}" value=#{currentVal} step="any">+ |]()++inputBox :: (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+ in ( \pPosition -> [julius|+ $("#{rawJS inputElId}").click(function(e){+ e.stopPropagation();+ })+ $("#{rawJS inputElId}").change(function(e){+ currentVal = $("#{rawJS inputElId}").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);+ })+ |]+ , inputElemHtml currentVal hashedId+ ) )+ where leafNm = " input"+ infixr 6 $<> ($<>) :: (r ~ (), TMM.SymbolClass σ, TMM.SCConstraint σ LaTeX) => TMM.CAS (TMM.Infix LaTeX) (TMM.Encapsulation LaTeX) (TMM.SymbolD σ LaTeX)@@ -601,10 +743,18 @@ maths eqns = renderTeXMaths MathML.DisplayBlock . TMM.maths eqns renderTeXMaths :: MathML.DisplayType -> LaTeX -> IPresentation m ()-renderTeXMaths dispSty tex = case MathML.readTeX . Txt.unpack $ LaTeX.render tex of+renderTeXMaths dispSty tex = case MathML.readTeX+#if !MIN_VERSION_texmath(0,12,0)+ . Txt.unpack+#endif+ $ LaTeX.render tex of Right exps -> StaticContent . HTM.preEscapedText . Txt.pack . XML.showElement $ MathML.writeMathML dispSty exps- Left err -> error $ "Failed to re-parse generated LaTeX. "++err+ Left err -> error $ "Failed to re-parse generated LaTeX. "+++#if MIN_VERSION_texmath(0,12,0)+ Txt.unpack+#endif+ err -- | Include a piece of plaintext, preserving all formatting. To be used in an -- oxford bracket.@@ -631,7 +781,7 @@ | otherwise = preescapeInline s preescapeBlock s = intercalate "<br>" $ drop zeroIndent <$> sLines where zeroIndent = minimum $ length . takeWhile (==' ') <$> sLines- sLines = lines s+ sLines = preescapeInline <$> lines s preescapeInline = concatMap preescapeChar preescapeChar '<' = "<" preescapeChar '>' = ">"@@ -733,13 +883,17 @@ CustomFile use -> use servableFile +getSetValR :: PresProgress -> PrPath -> ValueToSet -> Handler Text+getSetValR oldPosition path+ = getChPosR oldPosition . PositionChange path . PositionSetValue+ getChPosR :: PresProgress -> PositionChange -> Handler Text getChPosR oldPosition posStep = do newPosition <- execStateT (changePos_State posStep) oldPosition toTextUrl $ ExactPositionR newPosition changePos_State :: PositionChange -> StateT PresProgress Handler ()-changePos_State (PositionChange path isRevert) = do+changePos_State (PositionChange path pChangeKind) = do PresentationServer presentation _ _ <- getYesod go ("", defaultChoiceName, "") (finePath <$> Txt.words path) presentation return ()@@ -756,17 +910,34 @@ ( Maybe r -- Key value this branch yields , Bool ) -- Whether it contains displayable content go _ [] (StaticContent _) = return $ (Just (), True)+ go (crumbh,choiceName,crumbp) [] (TweakableInput defV twInp) = do+ let (pathFin, _) = twInp crumbh+ fullPath = crumbh<>pathFin+ case pChangeKind of+ PositionSetValue (ValueToSet newVal)+ -> case JSON.fromJSON newVal of+ JSON.Success v -> do+ setProgress fullPath v+ return (Just $ Just v, True)+ JSON.Error e -> fail e+ _ -> do+ key <- lookupProgress fullPath+ let result = case (key, defV) of+ (Just v, _) -> Just v+ (_, Just v) -> Just v+ (Nothing, Nothing) -> Nothing+ return $ (Just result, True) go _ [] (Pure x) = return $ (Just x, False) go _ [] (Interactive _ q) = (,error "Don't know if interactive request actually shows something.") . Just <$> liftIO q- go crumbs path (Encaps (WithHeading _) (Identity cont))- = (,True) . fmap Identity . fst <$> go crumbs path cont- go crumbs path (Encaps (CustomEncapsulation _ _) cont)- = (,True) . sequence+ go crumbs path (Encaps (WithHeading _) ff (Identity cont))+ = (,True) . fmap (ff . Identity) . fst <$> go crumbs path cont+ go crumbs path (Encaps (CustomEncapsulation _ _) ff cont)+ = (,True) . fmap ff . sequence <$> traverse (\c -> fst <$> go crumbs path c) cont- go (crumbh,choiceName,crumbp) [] (Encaps ManualCSSClasses (WriterT conts))- = (,True) . sequence . WriterT <$> traverse+ go (crumbh,choiceName,crumbp) [] (Encaps ManualCSSClasses ff (WriterT conts))+ = (,True) . fmap ff . sequence . WriterT <$> traverse (\(c,ζ) -> (,ζ) . fst <$> go (crumbh<>case ζ of HTMDiv i -> " div."<>i HTMSpan i -> " span."<>i@@ -776,23 +947,24 @@ go crumbs [] (Resultless c) = (Just (),) <$> hasDisplayableContent crumbs c go crumbs path (Resultless c) = first (const $ Just()) <$> go crumbs path c go crumbs path (Interactive p _) = first (const Nothing) <$> go crumbs path p+ go crumbs path (Feedback p) = go crumbs path $ p Nothing go (crumbh, choiceName, crumbp) (('0':prog):path') (Dependent def _) = first (const Nothing) <$> go' (crumbh, choiceName, crumbp<>"0") (prog:path') def go (crumbh, choiceName, crumbp) path' (Dependent def opt) = do key <- lookupProgress $ crumbh <> " span."<>choiceName crumbp- case (key, path', isRevert) of+ case (key, path', pChangeKind) of (Just k, ('1':prog):path'', _) -> do (resKey, rHasContent) <- go' (crumbh, choiceName, crumbp<>"1") (prog:path'') $ opt k- if isRevert && not rHasContent then do+ if pChangeKind==PositionRevert && not rHasContent then do revertProgress $ crumbh <> " span."<>choiceName crumbp return (Nothing, False) else return (resKey, rHasContent) (Nothing, ('1':prog):path'', _) -> do (~(Just k), _) <- go' (crumbh, choiceName, crumbp<>"0") [] def go' (crumbh, choiceName, crumbp<>"1") (prog:path'') $ opt k- (_, [[]], False) -> do+ (_, [[]], PositionAdvance) -> do (key', _) <- go' (crumbh,choiceName,crumbp<>"0") [[]] def case key' of Just k -> do@@ -800,23 +972,23 @@ skipContentless (crumbh, choiceName, crumbp<>"1") $ opt k return (Nothing, True) Nothing -> error $ outerConstructorName def ++ " refuses to yield a result value."- (_, [[]], True) -> do+ (_, [[]], PositionRevert) -> do revertProgress path lHasContent <- hasDisplayableContent (crumbh, choiceName, crumbp<>"0") def return (Nothing, lHasContent)- (Just k, [], False)+ (Just k, [], PositionAdvance) -> go' (crumbh, choiceName, crumbp<>"1") [] $ opt k- (Nothing, [], False)+ (Nothing, [], PositionAdvance) -> return (Nothing, False) (_, dir:_, _) -> error $ "Div-ID "++dir++" not suitable for making a Dependent choice." go crumbs path (Styling _ cont) = go crumbs path cont- go (crumbh, choiceName, _) (divid:path) (Encaps ManualCSSClasses (WriterT conts))+ go (crumbh, choiceName, _) (divid:path) (Encaps ManualCSSClasses ff (WriterT conts)) | Just dividt <- HTMDiv<$>Txt.stripPrefix "div." (Txt.pack divid) <|> HTMSpan<$>Txt.stripPrefix "span." (Txt.pack divid) , Just subSel <- lookup dividt $ swap<$>conts- = first (fmap $ WriterT . pure . (,dividt))+ = first (fmap $ ff . WriterT . pure . (,dividt)) <$> go (crumbh<>case dividt of HTMDiv i -> " div."<>i HTMSpan i -> " span."<>i@@ -864,7 +1036,7 @@ skipContentless crumbs (Deterministic f c) = fmap f <$> skipContentless crumbs c skipContentless _ (StaticContent _) = return Nothing- skipContentless _ (Encaps _ _) = return Nothing+ skipContentless _ (Encaps _ _ _) = return Nothing skipContentless _ p = error $ "`skipContentless` does not support "++outerConstructorName p @@ -886,7 +1058,7 @@ hasDisplayableContent crumbs (Deterministic f c) = hasDisplayableContent crumbs c hasDisplayableContent _ (StaticContent _) = return True- hasDisplayableContent _ (Encaps _ _) = return True+ hasDisplayableContent _ (Encaps _ _ _) = return True hasDisplayableContent _ p = error $ "`hasDisplayableContent` does not support "++outerConstructorName p @@ -910,7 +1082,7 @@ class (MonadHandler m) => KnowsProgressState m where- lookupProgress :: Flat x => PrPath -> m (Maybe x)+ lookupProgress :: (HasCallStack, Flat x) => PrPath -> m (Maybe x) instance MonadHandler m => KnowsProgressState (StateT PresProgress m) where@@ -963,3 +1135,149 @@ -- in a web browser, on port 14910. This is a shorthand for @'yeamer'' 'def'@. yeamer :: Presentation -> IO () yeamer = yeamer' def++++data DisplayOrientation = DisplayHorizontally | DisplayVertically+ deriving (Eq, Show, Generic)+otherDisplayOrientation :: DisplayOrientation -> DisplayOrientation+otherDisplayOrientation DisplayHorizontally = DisplayVertically+otherDisplayOrientation DisplayVertically = DisplayHorizontally++class InteractiveShow a where+ display :: a -> Presentation+ display = displayOriented DisplayHorizontally+ displayOriented :: DisplayOrientation -> a -> Presentation+ default displayOriented :: (Generic a, GInteractiveShow (Rep a))+ => DisplayOrientation -> a -> Presentation+ displayOriented orient = gDisplayOriented orient . from+ displayList :: DisplayOrientation -> [a] -> Presentation+ displayList orient = go 1+ where go _ [] = "[]"+ go n xs = case splitAt (sum [1..n]) xs of+ (l₀:r@(_:_),[])+ -> let m = init r; ω = last r+ in foldr1 catOp $ ["["│display' l₀│" "]+ ++ map ((","│).(│" ").display') m+ ++ [","│display' ω│"]"]+ (l,[])+ -> "[" │ foldr1 (│) (display'<$>l) │ "]"+ (l₀:r@(_:_),_)+ -> (let m = init r; ω = last r+ in foldr1 catOp $ ["("│display' l₀]+ ++ map ((":"│).display') m+ ++ [ ":"│display' ω+ , ":"│"...)" ]+ ) >>= \() -> go (n + 1) xs+ (l,_) -> "(" │ foldr1 (│) (display'<$>l) │ ":" │ "..." │ ")"+ >>= \() -> go (n + 1) xs+ catOp = case orient of+ DisplayHorizontally -> (│)+ DisplayVertically -> (──)+ display' = displayOriented $ otherDisplayOrientation orient++class GInteractiveShow f where+ gDisplayOriented :: DisplayOrientation -> f p -> Presentation++instance InteractiveShow Char where+ displayOriented _ c = fromString $ show c+ displayList _ s = fromString $ show s+instance InteractiveShow Int where displayOriented _ s = fromString $ show s+instance InteractiveShow Int64 where displayOriented _ s = fromString $ show s+instance InteractiveShow Int32 where displayOriented _ s = fromString $ show s+instance InteractiveShow Int16 where displayOriented _ s = fromString $ show s+instance InteractiveShow Double where+ displayOriented _ x+ | fromIntegral rounded == x = display rounded+ | read imprecise == x = fromString imprecise+ | otherwise = do+ approxShw+ fromString $ show x+ where rounded = round x :: Int16+ imprecise = printf "%.1g" x+ approxShw = case break (=='e') imprecise of+ (man,ex) -> fromString $ man ++ "…" ++ ex+instance InteractiveShow a => InteractiveShow [a] where+ displayOriented = displayList+++instance GInteractiveShow V1 where+ gDisplayOriented _ a = case a of {}+instance GInteractiveShow U1 where+ gDisplayOriented _ _ = mempty+instance (GInteractiveShow l, GInteractiveShow r) => GInteractiveShow (l:+:r) where+ gDisplayOriented orient (L1 x) = gDisplayOriented orient x+ gDisplayOriented orient (R1 y) = gDisplayOriented orient y+instance (GInteractiveShow l, GInteractiveShow r) => GInteractiveShow (l:*:r) where+ gDisplayOriented orient (x:*:y) = gDisplayOriented orient x ⊕ gDisplayOriented orient y+ where (⊕) = case orient of DisplayHorizontally -> (│)+ DisplayVertically -> (──)+instance InteractiveShow a => GInteractiveShow (K1 i a) where+ gDisplayOriented orient (K1 x)+ = displayOriented (otherDisplayOrientation orient) x++instance GInteractiveShow f => GInteractiveShow (M1 i ('MetaData ν μ π τ) f) where+ gDisplayOriented orient (M1 x) = dispDataEncapsulated $ gDisplayOriented orient x+instance KnownSymbol n+ => GInteractiveShow (M1 i ('MetaCons n φ σ) U1) where+ gDisplayOriented orient (M1 x) = dispConstructorLabel @n+instance (GInteractiveShow f, GInteractiveShow g, KnownSymbol n)+ => GInteractiveShow (M1 i ('MetaCons n φ σ) (f:*:g)) where+ gDisplayOriented orient (M1 x) = styling ([cassius|+ .yeamer-display-dataFields-vert>.autogrid>div+ border-top: 1px dashed+ .yeamer-display-dataFields-horiz>.autogrid>div+ border-left: 1px dashed+ |]())+ $ dispConstructorLabel @n+ <> divClass ("yeamer-display-dataFields-"<>rfOrient)+ (gDisplayOriented orient x)+ where rfOrient = case orient of DisplayHorizontally -> "horiz"+ DisplayVertically -> "vert"+instance (GInteractiveShow (M1 j μ f), KnownSymbol n)+ => GInteractiveShow (M1 i ('MetaCons n φ σ)+ (M1 j μ f)) where+ gDisplayOriented orient (M1 x) = dispConstructorLabel @n+ ── gDisplayOriented (otherDisplayOrientation orient+ -- single-field cons: undo K1 direction-change+ ) x++instance GInteractiveShow f+ => GInteractiveShow (M1 i ('MetaSel 'Nothing υ σ 'DecidedStrict) f) where+ gDisplayOriented orient (M1 x) = gDisplayOriented orient x+instance GInteractiveShow f+ => GInteractiveShow (M1 i ('MetaSel 'Nothing υ σ 'DecidedUnpack) f) where+ gDisplayOriented orient (M1 x) = gDisplayOriented orient x+instance GInteractiveShow f+ => GInteractiveShow (M1 i ('MetaSel 'Nothing υ σ 'DecidedLazy) f) where+ gDisplayOriented orient (M1 x) = "..." >>= \() -> gDisplayOriented orient x+instance (GInteractiveShow f, KnownSymbol n)+ => GInteractiveShow (M1 i ('MetaSel ('Just n) υ σ 'DecidedStrict) f) where+ gDisplayOriented orient (M1 x)+ = dispRecFieldLabel @n ⊕ gDisplayOriented orient x+ where (⊕) = case orient of DisplayHorizontally -> (──)+ DisplayVertically -> (│)+instance (GInteractiveShow f, KnownSymbol n)+ => GInteractiveShow (M1 i ('MetaSel ('Just n) υ σ 'DecidedUnpack) f) where+ gDisplayOriented orient (M1 x)+ = dispRecFieldLabel @n ⊕ gDisplayOriented orient x+ where (⊕) = case orient of DisplayHorizontally -> (──)+ DisplayVertically -> (│)+instance (GInteractiveShow f, KnownSymbol n)+ => GInteractiveShow (M1 i ('MetaSel ('Just n) υ σ 'DecidedLazy) f) where+ gDisplayOriented orient (M1 x)+ = (dispRecFieldLabel @n ⊕ "...")+ >>= \() -> (dispRecFieldLabel @n ⊕ gDisplayOriented orient x)+ where (⊕) = case orient of DisplayHorizontally -> (──)+ DisplayVertically -> (│)++dispDataEncapsulated :: Presentation -> Presentation+dispDataEncapsulated = divClass "yeamer-display-dataEncapsulation"++dispConstructorLabel :: ∀ n . KnownSymbol n => Presentation+dispConstructorLabel = divClass "yeamer-display-dataConstructorName"+ $ fromString (symbolVal @n Proxy)++dispRecFieldLabel :: ∀ n . KnownSymbol n => Presentation+dispRecFieldLabel = divClass "yeamer-display-recordFieldLabel"+ $ fromString (symbolVal @n Proxy ++ "=")
Presentation/Yeamer/Internal/Grid.hs view
@@ -3,7 +3,7 @@ -- Copyright : (c) Justus Sagemüller 2017 -- License : GPL v3 -- --- Maintainer : (@) jsagemue $ uni-koeln.de+-- Maintainer : (@) jsag $ hvl.no -- Stability : experimental -- Portability : portable -- @@ -24,7 +24,7 @@ import GHC.Generics import Data.Aeson (FromJSON, ToJSON)-import Data.Flat (Flat)+import Flat (Flat) import Data.Ratio ((%)) @@ -32,6 +32,7 @@ import Data.Ord (comparing) import Control.Applicative (liftA2)+import Control.Monad.Trans.State import Control.Arrow (second) import Lens.Micro@@ -80,25 +81,39 @@ makeLenses ''GridLayout layoutGrid :: Gridded a -> GridLayout a--- layoutGrid = fmap snd . fst . layoutGridP+layoutGrid = fmap snd . fst . layoutGridP type GridRegionId = Int layoutGridP :: Gridded a -> ( GridLayout (GridRegionId, a) , [(GridRegionId, b)] -> Gridded b )-layoutGridP g = ( layoutGrid g & gridContents %~ zipWith (second . (,)) [0..]- , const undefined )--layoutGrid (GridRegion a) = GridLayout 1 1 [(GridRange 0 1 0 1, a)]-layoutGrid (GridDivisions []) = GridLayout 0 0 []-layoutGrid (GridDivisions [row])- = alignLayoutDirectional gridWidth xBegin xEnd+layoutGridP = (`evalState`0) . go+ where go (GridRegion a) = do+ i <- get+ put $ i+1+ return ( GridLayout 1 1 [(GridRange 0 1 0 1, (i, a))]+ , \[(_, b)] -> GridRegion b )+ go (GridDivisions [[GridRegion a₀, GridRegion a₁]]) = do+ i <- get+ put $ i+2+ return ( GridLayout 2 1 [ (GridRange 0 1 0 1, (i, a₀))+ , (GridRange 1 2 0 1, (i+1, a₁)) ]+ , \[(_,b₀), (_,b₁)] -> GridDivisions [[GridRegion b₀,GridRegion b₁]] )+ go (GridDivisions []) + = return ( GridLayout 0 0 []+ , \[] -> GridDivisions [] )+ go (GridDivisions [row]) = do+ layouts <- mapM go row+ return ( alignLayoutDirectional gridWidth xBegin xEnd gridHeight yBegin yEnd- $ layoutGrid <$> row-layoutGrid (GridDivisions rows)- = alignLayoutDirectional gridHeight yBegin yEnd+ (fst<$>layouts)+ , undefined )+ go (GridDivisions rows) = do+ rLayouts <- mapM (go . GridDivisions . pure) rows+ return ( alignLayoutDirectional gridHeight yBegin yEnd gridWidth xBegin xEnd- $ layoutGrid . GridDivisions . pure <$> rows+ (fst<$>rLayouts)+ , undefined ) alignLayoutDirectional :: Lens' (GridLayout a) Int -> Lens' GridRange Int -> Lens' GridRange Int
Presentation/Yeamer/Internal/PrPathStepCompression.hs view
@@ -3,7 +3,7 @@ -- Copyright : (c) Justus Sagemüller 2017 -- License : GPL v3 -- --- Maintainer : (@) jsagemue $ uni-koeln.de+-- Maintainer : (@) jsag $ hvl.no -- Stability : experimental -- Portability : portable --
Presentation/Yeamer/Internal/Progress.hs view
@@ -3,7 +3,7 @@ -- Copyright : (c) Justus Sagemüller 2018 -- License : GPL v3 -- --- Maintainer : (@) jsagemue $ uni-koeln.de+-- Maintainer : (@) jsag $ hvl.no -- Stability : experimental -- Portability : portable -- @@ -18,11 +18,13 @@ import qualified Data.Vector as Arr import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BSL import Data.Text (Text) import qualified Data.Text.Encoding as Txt import qualified Data.ByteString.Base64.URL as URLBase64 -import Data.Flat (Flat, flat, unflat)+import Flat (Flat, flat, unflat)+import qualified Flat.Class as Flat import qualified Data.Aeson as JSON import Yesod (PathPiece(..))@@ -70,9 +72,35 @@ (compressedProgs,progKeyRsr) = rmRedundancy $ Map.fromList keyCompressed +-- | A hack to embed interactive values from JavaScript.+data ValueToSet = NoValGiven+ | ValueToSet { getValueToSet :: JSON.Value }+ deriving (Eq,Show,Read)++instance JSON.FromJSON ValueToSet where+ parseJSON = pure . ValueToSet++instance Flat ValueToSet where+ encode (ValueToSet v) = Flat.encode $ JSON.encode v+ encode NoValGiven = Flat.encode ()+ decode = do+ vj <- Flat.decode+ case JSON.eitherDecode vj of+ Left err -> fail err+ Right v -> pure v+ size (ValueToSet v) = Flat.size $ JSON.encode v++data PositionChangeKind+ = PositionAdvance+ | PositionRevert+ | PositionSetValue ValueToSet+ deriving (Generic, Eq, Show, Read)+instance JSON.FromJSON PositionChangeKind+instance Flat PositionChangeKind+ data PositionChange = PositionChange { posChangeLevel :: PrPath- , posChangeIsRevert :: Bool+ , posChangeKind :: PositionChangeKind } deriving (Generic, Eq, Show, Read) instance JSON.FromJSON PositionChange @@ -84,3 +112,14 @@ = Txt.decodeUtf8 <<< URLBase64.encode $ flat (lvl, isRev)+++instance PathPiece ValueToSet where+ fromPathPiece = Txt.encodeUtf8+ >>> JSON.decodeStrict+ >>> fmap ValueToSet+ toPathPiece NoValGiven = mempty+ toPathPiece (ValueToSet val) = Txt.decodeUtf8+ <<< BSL.toStrict+ <<< JSON.encode+ $ val
Presentation/Yeamer/Maths.hs view
@@ -3,7 +3,7 @@ -- Copyright : (c) Justus Sagemüller 2017 -- License : GPL v3 -- --- Maintainer : (@) jsagemue $ uni-koeln.de+-- Maintainer : (@) jsag $ hvl.no -- Stability : experimental -- Portability : portable --
test/Main.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-} import Presentation.Yeamer import Presentation.Yeamer.Maths@@ -14,13 +16,15 @@ import Data.Time.Clock import Data.Time.Clock.POSIX -import Data.Flat (Flat(..))+import Flat (Flat(..)) import qualified Diagrams.Prelude as Dia import qualified Diagrams.Backend.Cairo as Dia import Data.Function +import GHC.Generics+ main :: IO () main = yeamer . styling ([lucius| body {@@ -45,6 +49,27 @@ display: flex; flex-direction: column; }+ .yeamer-display-dataEncapsulation {+ border: 1px solid white;+ border-radius: 15px;+ overflow: hidden;+ width: 90%;+ height: 90%;+ }+ .yeamer-display-dataConstructorName {+ font-weight: bold;+ background-color: #222;+ }+ .yeamer-display-dataConstructorName+ , .yeamer-display-dataFields-vert+ , .yeamer-display-dataFields-horiz {+ height: max-content;+ }+ .yeamer-display-recordFieldLabel {+ text-align: left;+ font-size: 70%;+ max-height: 1em;+ } |] ()) $ do @@ -52,6 +77,13 @@ ====== "Simple test “presentation”" + "Int boxes"+ ====== do+ (const() <$> inputBox @Int 1 →│→ \i -> fromString $ "Value is "<>show i)+ ──+ (const() <$> (inputBox @Double 2 →│← inputBox pi) →│→ \(i,j)+ -> fromString ("Sum is "<>show (i+j))+ ) "Code block" ====== [plaintext|@@ -59,8 +91,25 @@ blub bli blum+ <wun> |]+ + "Lazy Haskell structures"+ ====== do+ "Lists"+ ====== do+ display [0::Int .. 16]+ ──+ display[ [0..n]+ | n <- [0::Int .. ] ]+ "Records"+ ====== do+ display [ RecordTest 1 Alt₀Test+ , RecordTest 1 (Alt₁Test $ RecordTest 2 ["foo","bar"]) ]+ ──+ display( RecordTest 9 (Alt₁Test $ RecordTest 37 []) ) + "Some maths" ====== "Let's consider "<> 𝑎*𝑏/(7-pi) $<>". This ensures"@@ -142,3 +191,15 @@ decode = fmap (posixSecondsToUTCTime . realToFrac . (id::Double->Double)) decode encode = encode . (id::Double->Double) . realToFrac . utcTimeToPOSIXSeconds size = size . (id::Double->Double) . realToFrac . utcTimeToPOSIXSeconds++++data RecordDisplayTest a = RecordTest { rtSel₀ :: !Int, rtSel₁ :: a }+ deriving (Generic)++data AlternativeDisplayTest = Alt₀Test+ | Alt₁Test (RecordDisplayTest [String])+ deriving (Generic)++instance InteractiveShow a => InteractiveShow (RecordDisplayTest a)+instance InteractiveShow AlternativeDisplayTest
yeamer.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: yeamer-version: 0.1.0.5+version: 0.1.1.0 synopsis: Yesod-based server for interactive presentation slides -- description: homepage: https://github.com/leftaroundabout/yeamer@@ -36,20 +36,20 @@ , data-default-class , numbered-semigroups >=0.1 && <0.2 , transformers- , TeX-my-math >=0.201.0.0 && < 0.202+ , TeX-my-math >=0.201.0.0 && < 0.203 , dumb-cas , HaTeX- , texmath >=0.9 && <0.12+ , texmath >=0.9 && <0.13 , xml , containers , microlens >=0.4 && <0.6 , microlens-th- , these >=0.7 && <1.1+ , these >=0.7 && <1.2 , these-lens , text , bytestring , base64-bytestring - , flat >0.3.1 && <0.4+ , flat >0.4 && <0.5 , aeson , zlib , filepath