summaryrefslogtreecommitdiff
path: root/src/Data/Linked.hs
blob: de1dc771f574df868ec2fd8af8fe6ea54c4d8c49 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
module Data.Linked
    ( Linked (..)
    , linkedHtml
    , ToMaybe (..)
    ) where

import Prelude hiding (span)
import Prolog
import Data.Proxy
import Network.URI
import Text.Blaze.Html
import Text.Blaze.Html5 (a, span)
import Text.Blaze.Html5.Attributes (href, class_)


data Linked l t a = Linked
    { baseText :: !a
    , link :: !(l URI)
    , tooltip :: !(t a)
    }


linkedHtml :: (ToMarkup a, ToMaybe l, ToMaybe t) => Linked l t a -> Html
-- linkedHtml (Linked t (toMaybe -> Nothing) (toMaybe -> Nothing)) = toMarkup t
linkedHtml (Linked t (toMaybe -> l) (toMaybe -> tt)) =
    maybe id (\x -> a ! href (toValue x)) l $ maybe id withToolTip tt $ toMarkup t
    -- a ! (maybe mempty (\x -> href $ toValue x) l) $ maybe id withToolTip tt $ toMarkup t
-- ! (maybe mempty (\_ -> class_ "has-tooltip") tt) $ toMarkup t <> (maybe mempty (\x -> span ! class_ "tooltip" $ toMarkup x) tt)


withToolTip :: (ToMarkup t) => t -> Html -> Html
withToolTip tt h = a ! class_ "has-tooltip" $ h <> (span ! class_ "tooltip" $ toMarkup tt)

class ToMaybe f where
    toMaybe :: Alternative m => f a -> m a

instance ToMaybe Maybe where
    toMaybe = liftMaybe

instance ToMaybe Identity where
    toMaybe (Identity x) = pure x

instance ToMaybe Proxy where
    toMaybe _ = empty