diff --git a/lib/Lucid/Rdash.hs b/lib/Lucid/Rdash.hs --- a/lib/Lucid/Rdash.hs +++ b/lib/Lucid/Rdash.hs @@ -27,6 +27,7 @@ , SidebarItem(..) ) where +import Control.Applicative ((<$>)) import qualified Data.Text as T import Data.List @@ -34,7 +35,7 @@ import Lucid hiding (toHtml) import qualified Lucid (toHtml) -import Data.Monoid ((<>)) +import Data.Monoid ((<>), mempty) toHtml :: Monad m => T.Text -> HtmlT m () toHtml = Lucid.toHtml diff --git a/lib/Lucid/Tables.hs b/lib/Lucid/Tables.hs new file mode 100644 --- /dev/null +++ b/lib/Lucid/Tables.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules,FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures,FlexibleContexts,TypeApplications,TypeOperators #-} +{-# LANGUAGE InstanceSigs, TypeSynonymInstances,ScopedTypeVariables, DeriveGeneric #-} +{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, DeriveGeneric, DefaultSignatures, + PolyKinds, TypeOperators, ScopedTypeVariables, FlexibleContexts, + FlexibleInstances, UndecidableInstances, + OverloadedStrings, TypeApplications, StandaloneDeriving #-} + +module Lucid.Tables where + +import Lucid +import Data.Proxy +import qualified Data.Text as T +import GHC.Generics +import Data.Monoid + +class ToHtmlTable a where + headers:: Proxy a->[T.Text] + + default headers:: (Generic a,TableSelectors (Rep a)) => Proxy a -> [T.Text] + headers = map (T.pack) . tableSelectors + + toHtmlRow:: Monad m => a ->[HtmlT m ()] + default toHtmlRow:: (Monad m, Generic a, GToTable (Rep a)) => a -> [HtmlT m ()] + toHtmlRow a = gtoHtmlRow (from a) + + +class GToTable f where + gtoHtmlRow:: Monad m => f a ->[HtmlT m ()] + +instance GToTable U1 where + gtoHtmlRow U1 = [] + +instance GToTable a => GToTable (M1 C c a) where + + gtoHtmlRow =gtoHtmlRow . unM1 + + +instance GToTable a => GToTable (M1 D c a) where + + gtoHtmlRow =gtoHtmlRow . unM1 + +instance (GToTable a, GToTable b) => GToTable (a :*: b) where + gtoHtmlRow (a :*: b) = (gtoHtmlRow a) <> (gtoHtmlRow b) + +instance (Selector d, ToHtml a) => GToTable (M1 S d (K1 R a)) where + + gtoHtmlRow (M1 (K1 x)) =[toHtml x ] + +-- https://hackage.haskell.org/package/hpack-0.15.0/src/src/Hpack/GenericsUtil.hs +-- Copyright (c) 2014-2016 Simon Hengel + +tableSelectors :: (TableSelectors (Rep a)) => Proxy a -> [String] +tableSelectors = f + where + f :: forall a. (TableSelectors (Rep a)) => Proxy a -> [String] + f _ = selNames (Proxy :: Proxy (Rep a)) + +class TableSelectors a where + selNames :: Proxy a -> [String] + +instance TableSelectors f => TableSelectors (M1 D x f) where + selNames _ = selNames (Proxy :: Proxy f) + +instance TableSelectors f => TableSelectors (M1 C x f) where + selNames _ = selNames (Proxy :: Proxy f) + +instance Selector s => TableSelectors (M1 S s (K1 R t)) where + selNames _ = [selName (undefined :: M1 S s (K1 R t) ())] + +instance (TableSelectors a, TableSelectors b) => TableSelectors (a :*: b) where + selNames _ = selNames (Proxy :: Proxy a) ++ selNames (Proxy :: Proxy b) + +instance TableSelectors U1 where + selNames _ = [] + +{- +data Test = Test{ + foo :: String, + bar ::String} deriving Generic + +instance ToHtmlTable Test + +h = headers $ Proxy @Test +b :: [Html ()] + +b = toHtmlRow $ Test "hello" "world" +g = from $ Test "hello" "world" +-} + + + diff --git a/lib/Lucid/VegaLite.hs b/lib/Lucid/VegaLite.hs new file mode 100644 --- /dev/null +++ b/lib/Lucid/VegaLite.hs @@ -0,0 +1,41 @@ +{-# language OverloadedStrings, ExtendedDefaultRules #-} +module Lucid.VegaLite (vegaEmbedHead, vegaEmbedBodyScript, mkVegaHtml) where + +import Lucid +import Lucid.PreEscaped (scriptSrc) + +import qualified Data.Aeson as A + +-- import qualified Data.Text as T +import qualified Data.Text.Encoding as T (decodeUtf8) + +import qualified Data.ByteString.Lazy as LBS + +import Data.Monoid + +vegaCDN, vegaLiteCDN, vegaEmbedCDN :: Monad m => HtmlT m () +vegaCDN = scriptSrc "https://cdn.jsdelivr.net/npm/vega@3" +vegaLiteCDN = scriptSrc "https://cdn.jsdelivr.net/npm/vega-lite@2.5.0" +vegaEmbedCDN = scriptSrc "https://cdn.jsdelivr.net/npm/vega-embed@3" + +-- | Construct a HTML page that can render a vega-lite plot. The plot will be rendered by the vega-embed library. +-- +-- NB: the 'A.Value' parameter must contain a vega-lite JSON payload +mkVegaHtml :: A.Value -> Html () +mkVegaHtml vl = doctypehtml_ $ html_ $ do + meta_ [charset_ "UTF-8"] + head_ vegaEmbedHead + with div_ [id_ "vis"] "" + body_ $ vegaEmbedBodyScript vl + +-- | The statements for downloading the vega javascript blobs from the CDN. Must be in the document \ +vegaEmbedHead :: Html () +vegaEmbedHead = do + vegaCDN + vegaLiteCDN + vegaEmbedCDN + +-- | The statement for embedding the vega JSON payload and initializing vega-embed. Must be in the \ block and referenced by a \
\ +vegaEmbedBodyScript :: A.Value -> Html () +vegaEmbedBodyScript vl = + script_ $ T.decodeUtf8 $ LBS.toStrict ("const spec =" <> A.encode vl <> "; vegaEmbed('#vis', spec).then(result => console.log(result)).catch(console.warn);" :: LBS.ByteString) diff --git a/lucid-extras.cabal b/lucid-extras.cabal --- a/lucid-extras.cabal +++ b/lucid-extras.cabal @@ -1,51 +1,55 @@ -Name: lucid-extras -Version: 0.1.0.1 -Synopsis: Generate more HTML with Lucid -Description: Generate more HTML with Lucid - Bootstrap, Rdash and Email. -License: MIT -License-file: LICENSE -Author: Tom Nielsen -Maintainer: Tom Nielsen -build-type: Simple -Cabal-Version: >= 1.10 -homepage: https://github.com/diffusionkinetics/open/lucid-extras -bug-reports: https://github.com/diffusionkinetics/open/issues -category: Web -Tested-With: GHC == 7.10.2, GHC == 7.10.3, GHC == 8.0.1 +cabal-version: >=1.10 +name: lucid-extras +version: 0.2 +license: MIT +license-file: LICENSE +maintainer: Tom Nielsen +author: Tom Nielsen +tested-with: ghc ==7.10.2 ghc ==7.10.3 ghc ==8.0.1 ghc ==8.0.2 +homepage: https://github.com/diffusionkinetics/open/lucid-extras +bug-reports: https://github.com/diffusionkinetics/open/issues +synopsis: Generate more HTML with Lucid +description: + Generate more HTML with Lucid - Bootstrap, Rdash, Vega-Lite, Email. +category: Web +build-type: Simple extra-source-files: - changelog.md + changelog.md source-repository head - type: git - location: https://github.com/diffusionkinetics/open - -Library - ghc-options: -Wall - hs-source-dirs: lib - default-language: Haskell2010 + type: git + location: https://github.com/diffusionkinetics/open - Exposed-modules: - Lucid.Bootstrap3 - , Lucid.PreEscaped - , Lucid.DataTables - , Lucid.Rdash - , Lucid.Leaflet - Build-depends: - base >= 4.6 && < 5 - , aeson - , lucid - , text - , blaze-builder - , bytestring +library + exposed-modules: + Lucid.Bootstrap3 + Lucid.PreEscaped + Lucid.DataTables + Lucid.Rdash + Lucid.Leaflet + Lucid.Tables + Lucid.VegaLite + hs-source-dirs: lib + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.6 && <5, + aeson >=1.1.2.0, + lucid >=2.9.9, + text >=1.2.2.2, + blaze-builder >=0.4.0.2, + bytestring >=0.10.8.1 -Test-suite site-gen - type: exitcode-stdio-1.0 - ghc-options: -Wall - hs-source-dirs: site-gen - main-is: Main.hs - default-language: Haskell2010 - other-modules: DevelMain - Build-Depends: base >= 4.6 && < 5 - , directory >= 1.2 - , lucid-extras - , lucid +test-suite site-gen + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: site-gen + other-modules: + DevelMain + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.6 && <5, + directory >=1.2, + lucid-extras -any, + lucid >=2.9.9