content: {-|
  Module      : Monomer.Widgets.Singles.ExternalLink
  Copyright   : (c) 2018 Francisco Vallarino
  License     : BSD-3-Clause (see the LICENSE file)
  Maintainer  : fjvallarino@gmail.com
  Stability   : experimental
  Portability : non-portable
  
  Provides a clickable link that is opened by the host OS. Since it relies on the
  OS to open the content, it is possible to open URIs other than urls.
  
  @
  externalLink "Open Wikipedia" "https://en.wikipedia.org"
  @
  -}
  {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE StrictData #-}
  
  module Monomer.Widgets.Singles.ExternalLink (
    -- * Configuration
    ExternalLinkCfg,
    -- * Constructors
    externalLink,
    externalLink_
  ) where
  
  import Control.Lens ((&), (^.), (.~))
  import Data.Default
  import Data.Text (Text)
  import System.Process (callCommand)
  
  import qualified Data.Sequence as Seq
  import qualified Data.Text as T
  
  import Monomer.Helper (catchAny)
  import Monomer.Widgets.Container
  import Monomer.Widgets.Singles.Label
  
  import qualified Monomer.Lens as L
  
  {-|
  Configuration options for externalLink:
  
  - 'trimSpaces': whether to remove leading/trailing spaces in the caption.
  - 'ellipsis': if ellipsis should be used for overflown text.
  - 'multiline': if text may be split in multiple lines.
  - 'maxLines': maximum number of text lines to show.
  - 'resizeFactor': flexibility to have more or less space assigned.
  - 'resizeFactorW': flexibility to have more or less horizontal space assigned.
  - 'resizeFactorH': flexibility to have more or less vertical space assigned.
  - 'onFocus': event to raise when focus is received.
  - 'onFocusReq': 'WidgetRequest' to generate when focus is received.
  - 'onBlur': event to raise when focus is lost.
  - 'onBlurReq': 'WidgetRequest' to generate when focus is lost.
  -}
  data ExternalLinkCfg s e = ExternalLinkCfg {
    _elcLabelCfg :: LabelCfg s e,
    _elcOnFocusReq :: [Path -> WidgetRequest s e],
    _elcOnBlurReq :: [Path -> WidgetRequest s e]
  }
  
  instance Default (ExternalLinkCfg s e) where
    def = ExternalLinkCfg {
      _elcLabelCfg = def,
      _elcOnFocusReq = [],
      _elcOnBlurReq = []
    }
  
  instance Semigroup (ExternalLinkCfg s e) where
    (<>) t1 t2 = ExternalLinkCfg {
      _elcLabelCfg = _elcLabelCfg t1 <> _elcLabelCfg t2,
      _elcOnFocusReq = _elcOnFocusReq t1 <> _elcOnFocusReq t2,
      _elcOnBlurReq = _elcOnBlurReq t1 <> _elcOnBlurReq t2
    }
  
  instance Monoid (ExternalLinkCfg s e) where
    mempty = def
  
  instance CmbTrimSpaces (ExternalLinkCfg s e) where
    trimSpaces_ trim = def {
      _elcLabelCfg = trimSpaces_ trim
    }
  
  instance CmbEllipsis (ExternalLinkCfg s e) where
    ellipsis_ ellipsis = def {
      _elcLabelCfg = ellipsis_ ellipsis
    }
  
  instance CmbMultiline (ExternalLinkCfg s e) where
    multiline_ multi = def {
      _elcLabelCfg = multiline_ multi
    }
  
  instance CmbMaxLines (ExternalLinkCfg s e) where
    maxLines count = def {
      _elcLabelCfg = maxLines count
    }
  
  instance CmbResizeFactor (ExternalLinkCfg s e) where
    resizeFactor s = def {
      _elcLabelCfg = resizeFactor s
    }
  
  instance CmbResizeFactorDim (ExternalLinkCfg s e) where
    resizeFactorW w = def {
      _elcLabelCfg = resizeFactorW w
    }
    resizeFactorH h = def {
      _elcLabelCfg = resizeFactorH h
    }
  
  instance WidgetEvent e => CmbOnFocus (ExternalLinkCfg s e) e Path where
    onFocus fn = def {
      _elcOnFocusReq = [RaiseEvent . fn]
    }
  
  instance CmbOnFocusReq (ExternalLinkCfg s e) s e Path where
    onFocusReq req = def {
      _elcOnFocusReq = [req]
    }
  
  instance WidgetEvent e => CmbOnBlur (ExternalLinkCfg s e) e Path where
    onBlur fn = def {
      _elcOnBlurReq = [RaiseEvent . fn]
    }
  
  instance CmbOnBlurReq (ExternalLinkCfg s e) s e Path where
    onBlurReq req = def {
      _elcOnBlurReq = [req]
    }
  
  -- | Creates an external link with the given caption and url.
  externalLink
    :: WidgetEvent e
    => Text            -- ^ The caption.
    -> Text            -- ^ The url.
    -> WidgetNode s e  -- ^ The created external link.
  externalLink caption url = externalLink_ caption url def
  
  -- | Creates an external link with the given caption and url. Accepts config.
  externalLink_
    :: WidgetEvent e
    => Text                   -- ^ The caption.
    -> Text                   -- ^ The url.
    -> [ExternalLinkCfg s e]  -- ^ The config options.
    -> WidgetNode s e         -- ^ The created external link.
  externalLink_ caption url configs = externalLinkNode where
    config = mconcat configs
    widget = makeExternalLink caption url config
    externalLinkNode = defaultWidgetNode "externalLink" widget
      & L.info . L.focusable .~ True
  
  makeExternalLink
    :: WidgetEvent e => Text -> Text -> ExternalLinkCfg s e -> Widget s e
  makeExternalLink !caption !url !config = widget where
    widget = createContainer () def {
      containerAddStyleReq = False,
      containerDrawDecorations = False,
      containerUseScissor = True,
      containerGetBaseStyle = getBaseStyle,
      containerInit = init,
      containerMerge = merge,
      containerHandleEvent = handleEvent,
      containerResize = resize
    }
  
    getBaseStyle wenv node = Just style where
      style = collectTheme wenv L.externalLinkStyle
  
    createChildNode wenv node = newNode where
      nodeStyle = node ^. L.info . L.style
      labelCfg = _elcLabelCfg config
      labelCurrStyle = labelCurrentStyle childOfFocusedStyle
      !labelNode = label_ caption [ignoreTheme, labelCfg, labelCurrStyle]
        & L.info . L.style .~ nodeStyle
      !newNode = node
        & L.children .~ Seq.singleton labelNode
  
    init wenv node = result where
      result = resultNode (createChildNode wenv node)
  
    merge wenv node oldNode oldState = result where
      result = resultNode (createChildNode wenv node)
  
    handleEvent wenv node target evt = case evt of
      Focus prev -> handleFocusChange node prev (_elcOnFocusReq config)
  
      Blur next -> handleFocusChange node next (_elcOnBlurReq config)
  
      KeyAction mode code status
        | isSelectKey code && status == KeyPressed -> Just result
        where
          isSelectKey code = isKeyReturn code || isKeySpace code
  
      Click p _ _
        | isPointInNodeVp node p -> Just result
  
      ButtonAction p btn BtnPressed 1 -- Set focus on click
        | mainBtn btn && pointInVp p && not focused -> Just resultFocus
  
      ButtonAction p btn BtnReleased clicks
        | mainBtn btn && focused && pointInVp p && clicks > 1 -> Just result
      _ -> Nothing
      where
        widgetId = node ^. L.info . L.widgetId
        path = node ^. L.info . L.path
        mainBtn btn = btn == wenv ^. L.mainButton
  
        focused = isNodeFocused wenv node
        pointInVp p = isPointInNodeVp node p
        openLinkTask = openLink wenv (T.unpack url)
  
        requests = [RunTask widgetId path openLinkTask]
        result = resultReqs node requests
        resultFocus = resultReqs node [SetFocus (node ^. L.info . L.widgetId)]
  
    resize wenv node viewport children = resized where
      assignedAreas = Seq.fromList [viewport]
      resized = (resultNode node, assignedAreas)
  
  openLink :: WidgetEnv s e -> String -> IO ()
  openLink wenv url = catchIgnore (callCommand openCommand) where
    os = wenv ^. L.os
    command
      | os == "Windows" = "start"
      | os == "Mac OS X" = "open"
      | os == "Linux" = "xdg-open"
      | otherwise = "ls"
    openCommand = command ++ " \"" ++ url ++ "\""
  
  catchIgnore :: IO () -> IO ()
  catchIgnore task = catchAny task (const $ return ())
  