Types.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
module IHaskell.Display.Widgets.Types where

-- | This module houses all the type-trickery needed to make widgets happen.
--
-- All widgets have a corresponding 'WidgetType', and some fields/attributes/properties as defined by
-- the 'WidgetFields' type-family.
--
-- Each widget field corresponds to a concrete haskell type, as given by the 'FieldType' type-family.
--
-- Vinyl records are used to wrap together widget fields into a single 'WidgetState'.
--
-- Singletons are used as a way to represent the promoted types of kind Field. For example:
--
-- @
-- SViewName :: SField ViewName
-- @
--
-- This allows the user to pass the type 'ViewName' without using Data.Proxy. In essence, a singleton
-- is the only inhabitant (other than bottom) of a promoted type. Single element set/type == singleton.
--
-- It also allows the record to wrap values of properties with information about their Field type. A
-- vinyl record is represented as @Rec f ts@, which means that a record is a list of @f x@, where @x@
-- is a type present in the type-level list @ts@. Thus a 'WidgetState' is essentially a list of field
-- properties wrapped together with the corresponding promoted Field type. See ('=::') for more.
--
-- The properties function can be used to view all the @Field@s associated with a widget object.
--
-- Attributes are represented by the @Attr@ data type, which holds the value of a field, along with
-- the actual @Field@ object and a function to verify validity of changes to the value.
--
-- The IPython widgets expect state updates of the form {"property": value}, where an empty string for
-- numeric values is ignored by the frontend and the default value is used instead. Some numbers need to
-- be sent as numbers (represented by @Integer@), whereas some need to be sent as Strings (@StrInt@).
--
-- Child widgets are expected to be sent as strings of the form "IPY_MODEL_<uuid>", where @<uuid>@
-- represents the uuid of the widget's comm.
--
-- To know more about the IPython messaging specification (as implemented in this package) take a look
-- at the supplied MsgSpec.md.
--
-- Widgets are not able to do console input, the reason for that can also be found in the messaging
-- specification
import Control.Monad (unless, join, when, void, mapM_)
import Control.Applicative ((<$>))
import qualified Control.Exception as Ex

import GHC.IO.Exception
import System.IO.Error
import System.Posix.IO

import Data.Aeson
import Data.Aeson.Types (Pair)
import Data.IORef (IORef, readIORef, modifyIORef)
import Data.Text (Text, pack)

import Data.Vinyl (Rec (..), (<+>), recordToList, reifyConstraint, rmap, Dict (..))
import Data.Vinyl.Functor (Compose (..), Const (..))
import Data.Vinyl.Lens (rget, rput, type (∈))
import Data.Vinyl.TypeLevel (RecAll)

import Data.Singletons.Prelude ((:++))
import Data.Singletons.TH

import IHaskell.Eval.Widgets (widgetSendUpdate)
import IHaskell.Display (Base64, IHaskellWidget (..))
import IHaskell.IPython.Message.UUID

import IHaskell.Display.Widgets.Singletons (Field, SField (..))
import qualified IHaskell.Display.Widgets.Singletons as S
import IHaskell.Display.Widgets.Common

-- Classes from IPython's widget hierarchy. Defined as such to reduce code duplication.
type WidgetClass = '[ S.ViewModule, S.ViewName, S.MsgThrottle, S.Version, S.DisplayHandler ]
type DOMWidgetClass = WidgetClass :++
   '[ S.Visible, S.CSS, S.DOMClasses, S.Width, S.Height, S.Padding, S.Margin, S.Color
    , S.BackgroundColor, S.BorderColor, S.BorderWidth, S.BorderRadius, S.BorderStyle, S.FontStyle
    , S.FontWeight, S.FontSize, S.FontFamily
    ]
type StringClass = DOMWidgetClass :++ '[S.StringValue, S.Disabled, S.Description, S.Placeholder]
type BoolClass = DOMWidgetClass :++ '[S.BoolValue, S.Disabled, S.Description, S.ChangeHandler]
type SelectionClass = DOMWidgetClass :++
   '[S.Options, S.SelectedValue, S.SelectedLabel, S.Disabled, S.Description, S.SelectionHandler]
type MultipleSelectionClass = DOMWidgetClass :++
   '[S.Options, S.SelectedLabels, S.SelectedValues, S.Disabled, S.Description, S.SelectionHandler]
type IntClass = DOMWidgetClass :++ '[S.IntValue, S.Disabled, S.Description, S.ChangeHandler]
type BoundedIntClass = IntClass :++ '[S.StepInt, S.MinInt, S.MaxInt]
type IntRangeClass = IntClass :++ '[S.IntPairValue, S.LowerInt, S.UpperInt]
type BoundedIntRangeClass = IntRangeClass :++ '[S.StepInt, S.MinInt, S.MaxInt]
type FloatClass = DOMWidgetClass :++ '[S.FloatValue, S.Disabled, S.Description, S.ChangeHandler]
type BoundedFloatClass = FloatClass :++ '[S.StepFloat, S.MinFloat, S.MaxFloat]
type FloatRangeClass = FloatClass :++ '[S.FloatPairValue, S.LowerFloat, S.UpperFloat]
type BoundedFloatRangeClass = FloatRangeClass :++ '[S.StepFloat, S.MinFloat, S.MaxFloat]
type BoxClass = DOMWidgetClass :++ '[S.Children, S.OverflowX, S.OverflowY, S.BoxStyle]
type SelectionContainerClass = BoxClass :++ '[S.Titles, S.SelectedIndex, S.ChangeHandler]

-- Types associated with Fields.
type family FieldType (f :: Field) :: * where
  FieldType S.ViewModule = Text
  FieldType S.ViewName = Text
  FieldType S.MsgThrottle = Integer
  FieldType S.Version = Integer
  FieldType S.DisplayHandler = IO ()
  FieldType S.Visible = Bool
  FieldType S.CSS = [(Text, Text, Text)]
  FieldType S.DOMClasses = [Text]
  FieldType S.Width = StrInt
  FieldType S.Height = StrInt
  FieldType S.Padding = StrInt
  FieldType S.Margin = StrInt
  FieldType S.Color = Text
  FieldType S.BackgroundColor = Text
  FieldType S.BorderColor = Text
  FieldType S.BorderWidth = StrInt
  FieldType S.BorderRadius = StrInt
  FieldType S.BorderStyle = BorderStyleValue
  FieldType S.FontStyle = FontStyleValue
  FieldType S.FontWeight = FontWeightValue
  FieldType S.FontSize = StrInt
  FieldType S.FontFamily = Text
  FieldType S.Description = Text
  FieldType S.ClickHandler = IO ()
  FieldType S.SubmitHandler = IO ()
  FieldType S.Disabled = Bool
  FieldType S.StringValue = Text
  FieldType S.Placeholder = Text
  FieldType S.Tooltip = Text
  FieldType S.Icon = Text
  FieldType S.ButtonStyle = ButtonStyleValue
  FieldType S.B64Value = Base64
  FieldType S.ImageFormat = ImageFormatValue
  FieldType S.BoolValue = Bool
  FieldType S.Options = SelectionOptions
  FieldType S.SelectedLabel = Text
  FieldType S.SelectedValue = Text
  FieldType S.SelectionHandler = IO ()
  FieldType S.Tooltips = [Text]
  FieldType S.Icons = [Text]
  FieldType S.SelectedLabels = [Text]
  FieldType S.SelectedValues = [Text]
  FieldType S.IntValue = Integer
  FieldType S.StepInt = Integer
  FieldType S.MinInt = Integer
  FieldType S.MaxInt = Integer
  FieldType S.LowerInt = Integer
  FieldType S.UpperInt = Integer
  FieldType S.IntPairValue = (Integer, Integer)
  FieldType S.Orientation = OrientationValue
  FieldType S.ShowRange = Bool
  FieldType S.ReadOut = Bool
  FieldType S.SliderColor = Text
  FieldType S.BarStyle = BarStyleValue
  FieldType S.FloatValue = Double
  FieldType S.StepFloat = Double
  FieldType S.MinFloat = Double
  FieldType S.MaxFloat = Double
  FieldType S.LowerFloat = Double
  FieldType S.UpperFloat = Double
  FieldType S.FloatPairValue = (Double, Double)
  FieldType S.ChangeHandler = IO ()
  FieldType S.Children = [ChildWidget]
  FieldType S.OverflowX = OverflowValue
  FieldType S.OverflowY = OverflowValue
  FieldType S.BoxStyle = BoxStyleValue
  FieldType S.Flex = Int
  FieldType S.Pack = LocationValue
  FieldType S.Align = LocationValue
  FieldType S.Titles = [Text]
  FieldType S.SelectedIndex = Integer

-- | Can be used to put different widgets in a list. Useful for dealing with children widgets.
data ChildWidget = forall w. RecAll Attr (WidgetFields w) ToPairs => ChildWidget (IPythonWidget w)

instance ToJSON ChildWidget where
  toJSON (ChildWidget x) = toJSON . pack $ "IPY_MODEL_" ++ uuidToString (uuid x)

-- Will use a custom class rather than a newtype wrapper with an orphan instance. The main issue is
-- the need of a Bounded instance for Float / Double.
class CustomBounded a where
  lowerBound :: a
  upperBound :: a

-- Set according to what IPython widgets use
instance CustomBounded StrInt where
  upperBound = 10 ^ 16 - 1
  lowerBound = - (10 ^ 16 - 1)

instance CustomBounded Integer where
  lowerBound = - (10 ^ 16 - 1)
  upperBound = 10 ^ 16 - 1

instance CustomBounded Double where
  lowerBound = - (10 ** 16 - 1)
  upperBound = 10 ** 16 - 1

-- Different types of widgets. Every widget in IPython has a corresponding WidgetType
data WidgetType = ButtonType
                | ImageType
                | OutputType
                | HTMLType
                | LatexType
                | TextType
                | TextAreaType
                | CheckBoxType
                | ToggleButtonType
                | DropdownType
                | RadioButtonsType
                | SelectType
                | ToggleButtonsType
                | SelectMultipleType
                | IntTextType
                | BoundedIntTextType
                | IntSliderType
                | IntProgressType
                | IntRangeSliderType
                | FloatTextType
                | BoundedFloatTextType
                | FloatSliderType
                | FloatProgressType
                | FloatRangeSliderType
                | BoxType
                | FlexBoxType
                | AccordionType
                | TabType

-- Fields associated with a widget
type family WidgetFields (w :: WidgetType) :: [Field] where
  WidgetFields ButtonType = DOMWidgetClass :++ '[S.Description, S.Tooltip, S.Disabled, S.Icon, S.ButtonStyle, S.ClickHandler]
  WidgetFields ImageType = DOMWidgetClass :++ '[S.ImageFormat, S.B64Value]
  WidgetFields OutputType = DOMWidgetClass
  WidgetFields HTMLType = StringClass
  WidgetFields LatexType = StringClass
  WidgetFields TextType = StringClass :++ '[S.SubmitHandler, S.ChangeHandler]
  WidgetFields TextAreaType = StringClass :++ '[S.ChangeHandler]
  WidgetFields CheckBoxType = BoolClass
  WidgetFields ToggleButtonType = BoolClass :++ '[S.Tooltip, S.Icon, S.ButtonStyle]
  WidgetFields DropdownType = SelectionClass :++ '[S.ButtonStyle]
  WidgetFields RadioButtonsType = SelectionClass
  WidgetFields SelectType = SelectionClass
  WidgetFields ToggleButtonsType = SelectionClass :++ '[S.Tooltips, S.Icons, S.ButtonStyle]
  WidgetFields SelectMultipleType = MultipleSelectionClass
  WidgetFields IntTextType = IntClass
  WidgetFields BoundedIntTextType = BoundedIntClass
  WidgetFields IntSliderType = BoundedIntClass :++ '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]
  WidgetFields IntProgressType = BoundedIntClass :++ '[S.BarStyle]
  WidgetFields IntRangeSliderType = BoundedIntRangeClass :++ '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]
  WidgetFields FloatTextType = FloatClass
  WidgetFields BoundedFloatTextType = BoundedFloatClass
  WidgetFields FloatSliderType = BoundedFloatClass :++ '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]
  WidgetFields FloatProgressType = BoundedFloatClass :++ '[S.BarStyle]
  WidgetFields FloatRangeSliderType = BoundedFloatRangeClass :++ '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]
  WidgetFields BoxType = BoxClass
  WidgetFields FlexBoxType = BoxClass :++ '[S.Orientation, S.Flex, S.Pack, S.Align]
  WidgetFields AccordionType = SelectionContainerClass
  WidgetFields TabType = SelectionContainerClass

-- Wrapper around a field's value. A dummy value is sent as an empty string to the frontend.
data AttrVal a = Dummy a | Real a

unwrap :: AttrVal a -> a
unwrap (Dummy x) = x
unwrap (Real x) = x

-- Wrapper around a field.
data Attr (f :: Field) =
  Attr { _value :: AttrVal (FieldType f)
       , _verify :: FieldType f -> IO (FieldType f)
       , _field :: Field
       }

instance ToJSON (FieldType f) => ToJSON (Attr f) where
  toJSON attr = case _value attr of
    Dummy _ -> ""
    Real x -> toJSON x

-- Types that can be converted to Aeson Pairs.
class ToPairs a where
  toPairs :: a -> [Pair]

-- Attributes that aren't synced with the frontend give [] on toPairs
instance ToPairs (Attr S.ViewModule) where toPairs x = ["_view_module" .= toJSON x]
instance ToPairs (Attr S.ViewName) where toPairs x = ["_view_name" .= toJSON x]
instance ToPairs (Attr S.MsgThrottle) where toPairs x = ["msg_throttle" .= toJSON x]
instance ToPairs (Attr S.Version) where toPairs x = ["version" .= toJSON x]
instance ToPairs (Attr S.DisplayHandler) where toPairs _ = [] -- Not sent to the frontend
instance ToPairs (Attr S.Visible) where toPairs x = ["visible" .= toJSON x]
instance ToPairs (Attr S.CSS) where toPairs x = ["_css" .= toJSON x]
instance ToPairs (Attr S.DOMClasses) where toPairs x = ["_dom_classes" .= toJSON x]
instance ToPairs (Attr S.Width) where toPairs x = ["width" .= toJSON x]
instance ToPairs (Attr S.Height) where toPairs x = ["height" .= toJSON x]
instance ToPairs (Attr S.Padding) where toPairs x = ["padding" .= toJSON x]
instance ToPairs (Attr S.Margin) where toPairs x = ["margin" .= toJSON x]
instance ToPairs (Attr S.Color) where toPairs x = ["color" .= toJSON x]
instance ToPairs (Attr S.BackgroundColor) where toPairs x = ["background_color" .= toJSON x]
instance ToPairs (Attr S.BorderColor) where toPairs x = ["border_color" .= toJSON x]
instance ToPairs (Attr S.BorderWidth) where toPairs x = ["border_width" .= toJSON x]
instance ToPairs (Attr S.BorderRadius) where toPairs x = ["border_radius" .= toJSON x]
instance ToPairs (Attr S.BorderStyle) where toPairs x = ["border_style" .= toJSON x]
instance ToPairs (Attr S.FontStyle) where toPairs x = ["font_style" .= toJSON x]
instance ToPairs (Attr S.FontWeight) where toPairs x = ["font_weight" .= toJSON x]
instance ToPairs (Attr S.FontSize) where toPairs x = ["font_size" .= toJSON x]
instance ToPairs (Attr S.FontFamily) where toPairs x = ["font_family" .= toJSON x]
instance ToPairs (Attr S.Description) where toPairs x = ["description" .= toJSON x]
instance ToPairs (Attr S.ClickHandler) where toPairs _ = [] -- Not sent to the frontend
instance ToPairs (Attr S.SubmitHandler) where toPairs _ = [] -- Not sent to the frontend
instance ToPairs (Attr S.Disabled) where toPairs x = ["disabled" .= toJSON x]
instance ToPairs (Attr S.StringValue) where toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr S.Placeholder) where toPairs x = ["placeholder" .= toJSON x]
instance ToPairs (Attr S.Tooltip) where toPairs x = ["tooltip" .= toJSON x]
instance ToPairs (Attr S.Icon) where toPairs x = ["icon" .= toJSON x]
instance ToPairs (Attr S.ButtonStyle) where toPairs x = ["button_style" .= toJSON x]
instance ToPairs (Attr S.B64Value) where toPairs x = ["_b64value" .= toJSON x]
instance ToPairs (Attr S.ImageFormat) where toPairs x = ["format" .= toJSON x]
instance ToPairs (Attr S.BoolValue) where toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr S.SelectedLabel) where toPairs x = ["selected_label" .= toJSON x]
instance ToPairs (Attr S.SelectedValue) where toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr S.Options) where
  toPairs x = case _value x of
    Dummy _ -> labels ("" :: Text)
    Real (OptionLabels xs) -> labels xs
    Real (OptionDict xps) -> labels $ map fst xps
    where labels xs = ["_options_labels" .= xs]
instance ToPairs (Attr S.SelectionHandler) where toPairs _ = [] -- Not sent to the frontend
instance ToPairs (Attr S.Tooltips) where toPairs x = ["tooltips" .= toJSON x]
instance ToPairs (Attr S.Icons) where toPairs x = ["icons" .= toJSON x]
instance ToPairs (Attr S.SelectedLabels) where toPairs x = ["selected_labels" .= toJSON x]
instance ToPairs (Attr S.SelectedValues) where toPairs x = ["values" .= toJSON x]
instance ToPairs (Attr S.IntValue) where toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr S.StepInt) where toPairs x = ["step" .= toJSON x]
instance ToPairs (Attr S.MinInt) where toPairs x = ["min" .= toJSON x]
instance ToPairs (Attr S.MaxInt) where toPairs x = ["max" .= toJSON x]
instance ToPairs (Attr S.IntPairValue) where toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr S.LowerInt) where toPairs x = ["min" .= toJSON x]
instance ToPairs (Attr S.UpperInt) where toPairs x = ["max" .= toJSON x]
instance ToPairs (Attr S.FloatValue) where toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr S.StepFloat) where toPairs x = ["step" .= toJSON x]
instance ToPairs (Attr S.MinFloat) where toPairs x = ["min" .= toJSON x]
instance ToPairs (Attr S.MaxFloat) where toPairs x = ["max" .= toJSON x]
instance ToPairs (Attr S.FloatPairValue) where toPairs x = ["value" .= toJSON x]
instance ToPairs (Attr S.LowerFloat) where toPairs x = ["min" .= toJSON x]
instance ToPairs (Attr S.UpperFloat) where toPairs x = ["max" .= toJSON x]
instance ToPairs (Attr S.Orientation) where toPairs x = ["orientation" .= toJSON x]
instance ToPairs (Attr S.ShowRange) where toPairs x = ["_range" .= toJSON x]
instance ToPairs (Attr S.ReadOut) where toPairs x = ["readout" .= toJSON x]
instance ToPairs (Attr S.SliderColor) where toPairs x = ["slider_color" .= toJSON x]
instance ToPairs (Attr S.BarStyle) where toPairs x = ["bar_style" .= toJSON x]
instance ToPairs (Attr S.ChangeHandler) where toPairs _ = [] -- Not sent to the frontend
instance ToPairs (Attr S.Children) where toPairs x = ["children" .= toJSON x]
instance ToPairs (Attr S.OverflowX) where toPairs x = ["overflow_x" .= toJSON x]
instance ToPairs (Attr S.OverflowY) where toPairs x = ["overflow_y" .= toJSON x]
instance ToPairs (Attr S.BoxStyle) where toPairs x = ["box_style" .= toJSON x]
instance ToPairs (Attr S.Flex) where toPairs x = ["flex" .= toJSON x]
instance ToPairs (Attr S.Pack) where toPairs x = ["pack" .= toJSON x]
instance ToPairs (Attr S.Align) where toPairs x = ["align" .= toJSON x]
instance ToPairs (Attr S.Titles) where toPairs x = ["_titles" .= toJSON x]
instance ToPairs (Attr S.SelectedIndex) where toPairs x = ["selected_index" .= toJSON x]

-- | Store the value for a field, as an object parametrized by the Field. No verification is done
-- for these values.
(=::) :: SingI f => Sing f -> FieldType f -> Attr f
s =:: x = Attr { _value = Real x, _verify = return, _field = reflect s }

-- | If the number is in the range, return it. Otherwise raise the appropriate (over/under)flow
-- exception.
rangeCheck :: (Num a, Ord a) => (a, a) -> a -> IO a
rangeCheck (l, u) x
  | l <= x && x <= u = return x
  | l > x = Ex.throw Ex.Underflow
  | u < x = Ex.throw Ex.Overflow

-- | Store a numeric value, with verification mechanism for its range.
ranged :: (SingI f, Num (FieldType f), Ord (FieldType f))
       => Sing f -> (FieldType f, FieldType f) -> AttrVal (FieldType f) -> Attr f
ranged s range x = Attr x (rangeCheck range) (reflect s)

-- | Store a numeric value, with the invariant that it stays non-negative. The value set is set as a
-- dummy value if it's equal to zero.
(=:+) :: (SingI f, Num (FieldType f), CustomBounded (FieldType f), Ord (FieldType f))
      => Sing f -> FieldType f -> Attr f
s =:+ val = Attr ((if val == 0 then Dummy else Real) val) (rangeCheck (0, upperBound)) (reflect s)

-- | Get a field from a singleton
-- Adapted from: http://stackoverflow.com/a/28033250/2388535
reflect :: forall (f :: Field). (SingI f, SingKind ('KProxy :: KProxy Field)) => Sing f -> Field
reflect = fromSing

-- | A record representing an object of the Widget class from IPython
defaultWidget :: FieldType S.ViewName -> Rec Attr WidgetClass
defaultWidget viewName = (ViewModule =:: "")
                      :& (ViewName =:: viewName)
                      :& (MsgThrottle =:+ 3)
                      :& (Version =:: 0)
                      :& (DisplayHandler =:: return ())
                      :& RNil

-- | A record representing an object of the DOMWidget class from IPython
defaultDOMWidget :: FieldType S.ViewName -> Rec Attr DOMWidgetClass
defaultDOMWidget viewName = defaultWidget viewName <+> domAttrs
  where domAttrs = (Visible =:: True)
                :& (CSS =:: [])
                :& (DOMClasses =:: [])
                :& (Width =:+ 0)
                :& (Height =:+ 0)
                :& (Padding =:+ 0)
                :& (Margin =:+ 0)
                :& (Color =:: "")
                :& (BackgroundColor =:: "")
                :& (BorderColor =:: "")
                :& (BorderWidth =:+ 0)
                :& (BorderRadius =:+ 0)
                :& (BorderStyle =:: DefaultBorder)
                :& (FontStyle =:: DefaultFont)
                :& (FontWeight =:: DefaultWeight)
                :& (FontSize =:+ 0)
                :& (FontFamily =:: "")
                :& RNil

-- | A record representing a widget of the _String class from IPython
defaultStringWidget :: FieldType S.ViewName -> Rec Attr StringClass
defaultStringWidget viewName = defaultDOMWidget viewName <+> strAttrs
  where strAttrs = (StringValue =:: "")
                :& (Disabled =:: False)
                :& (Description =:: "")
                :& (Placeholder =:: "")
                :& RNil

-- | A record representing a widget of the _Bool class from IPython
defaultBoolWidget :: FieldType S.ViewName -> Rec Attr BoolClass
defaultBoolWidget viewName = defaultDOMWidget viewName <+> boolAttrs
  where boolAttrs = (BoolValue =:: False)
                 :& (Disabled =:: False)
                 :& (Description =:: "")
                 :& (ChangeHandler =:: return ())
                 :& RNil

-- | A record representing a widget of the _Selection class from IPython
defaultSelectionWidget :: FieldType S.ViewName -> Rec Attr SelectionClass
defaultSelectionWidget viewName = defaultDOMWidget viewName <+> selectionAttrs
  where selectionAttrs = (Options =:: OptionLabels [])
                      :& (SelectedValue =:: "")
                      :& (SelectedLabel =:: "")
                      :& (Disabled =:: False)
                      :& (Description =:: "")
                      :& (SelectionHandler =:: return ())
                      :& RNil

-- | A record representing a widget of the _MultipleSelection class from IPython
defaultMultipleSelectionWidget :: FieldType S.ViewName -> Rec Attr MultipleSelectionClass
defaultMultipleSelectionWidget viewName = defaultDOMWidget viewName <+> mulSelAttrs
  where mulSelAttrs = (Options =:: OptionLabels [])
                   :& (SelectedLabels =:: [])
                   :& (SelectedValues =:: [])
                   :& (Disabled =:: False)
                   :& (Description =:: "")
                   :& (SelectionHandler =:: return ())
                   :& RNil

-- | A record representing a widget of the _Int class from IPython
defaultIntWidget :: FieldType S.ViewName -> Rec Attr IntClass
defaultIntWidget viewName = defaultDOMWidget viewName <+> intAttrs
  where intAttrs = (IntValue =:: 0)
                :& (Disabled =:: False)
                :& (Description =:: "")
                :& (ChangeHandler =:: return ())
                :& RNil

-- | A record representing a widget of the _BoundedInt class from IPython
defaultBoundedIntWidget :: FieldType S.ViewName -> Rec Attr BoundedIntClass
defaultBoundedIntWidget viewName = defaultIntWidget viewName <+> boundedIntAttrs
  where boundedIntAttrs = (StepInt =:: 1)
                       :& (MinInt =:: 0)
                       :& (MaxInt =:: 100)
                       :& RNil

-- | A record representing a widget of the _BoundedInt class from IPython
defaultIntRangeWidget :: FieldType S.ViewName -> Rec Attr IntRangeClass
defaultIntRangeWidget viewName = defaultIntWidget viewName <+> rangeAttrs
  where rangeAttrs = (IntPairValue =:: (25, 75))
                  :& (LowerInt =:: 0)
                  :& (UpperInt =:: 100)
                  :& RNil

-- | A record representing a widget of the _BoundedIntRange class from IPython
defaultBoundedIntRangeWidget :: FieldType S.ViewName -> Rec Attr BoundedIntRangeClass
defaultBoundedIntRangeWidget viewName = defaultIntRangeWidget viewName <+> boundedIntRangeAttrs
  where boundedIntRangeAttrs = (StepInt =:+ 1)
                            :& (MinInt =:: 0)
                            :& (MaxInt =:: 100)
                            :& RNil

-- | A record representing a widget of the _Float class from IPython
defaultFloatWidget :: FieldType S.ViewName -> Rec Attr FloatClass
defaultFloatWidget viewName = defaultDOMWidget viewName <+> intAttrs
  where intAttrs = (FloatValue =:: 0)
                :& (Disabled =:: False)
                :& (Description =:: "")
                :& (ChangeHandler =:: return ())
                :& RNil

-- | A record representing a widget of the _BoundedFloat class from IPython
defaultBoundedFloatWidget :: FieldType S.ViewName -> Rec Attr BoundedFloatClass
defaultBoundedFloatWidget viewName = defaultFloatWidget viewName <+> boundedFloatAttrs
  where boundedFloatAttrs = (StepFloat =:+ 1)
                         :& (MinFloat =:: 0)
                         :& (MaxFloat =:: 100)
                         :& RNil

-- | A record representing a widget of the _BoundedFloat class from IPython
defaultFloatRangeWidget :: FieldType S.ViewName -> Rec Attr FloatRangeClass
defaultFloatRangeWidget viewName = defaultFloatWidget viewName <+> rangeAttrs
  where rangeAttrs = (FloatPairValue =:: (25, 75))
                  :& (LowerFloat =:: 0)
                  :& (UpperFloat =:: 100)
                  :& RNil

-- | A record representing a widget of the _BoundedFloatRange class from IPython
defaultBoundedFloatRangeWidget :: FieldType S.ViewName -> Rec Attr BoundedFloatRangeClass
defaultBoundedFloatRangeWidget viewName = defaultFloatRangeWidget viewName <+> boundedFloatRangeAttrs
  where boundedFloatRangeAttrs = (StepFloat =:+ 1)
                              :& (MinFloat =:: 0)
                              :& (MaxFloat =:: 100)
                              :& RNil

-- | A record representing a widget of the _Box class from IPython
defaultBoxWidget :: FieldType S.ViewName -> Rec Attr BoxClass
defaultBoxWidget viewName = defaultDOMWidget viewName <+> boxAttrs
  where boxAttrs = (Children =:: [])
                :& (OverflowX =:: DefaultOverflow)
                :& (OverflowY =:: DefaultOverflow)
                :& (BoxStyle =:: DefaultBox)
                :& RNil

-- | A record representing a widget of the _SelectionContainer class from IPython
defaultSelectionContainerWidget :: FieldType S.ViewName -> Rec Attr SelectionContainerClass
defaultSelectionContainerWidget viewName = defaultBoxWidget viewName <+> selAttrs
  where selAttrs = (Titles =:: [])
                :& (SelectedIndex =:: 0)
                :& (ChangeHandler =:: return ())
                :& RNil

newtype WidgetState w = WidgetState { _getState :: Rec Attr (WidgetFields w) }

-- All records with ToPair instances for their Attrs will automatically have a toJSON instance now.
instance RecAll Attr (WidgetFields w) ToPairs => ToJSON (WidgetState w) where
  toJSON record =
    object
    . concat
    . recordToList
    . rmap (\(Compose (Dict x)) -> Const $ toPairs x)
    $ reifyConstraint (Proxy :: Proxy ToPairs) $ _getState record

data IPythonWidget (w :: WidgetType) = IPythonWidget { uuid :: UUID, state :: IORef (WidgetState w) }

-- | Change the value for a field, and notify the frontend about it.
setField :: (f ∈ WidgetFields w, IHaskellWidget (IPythonWidget w), ToPairs (Attr f))
         => IPythonWidget w -> SField f -> FieldType f -> IO ()
setField widget sfield fval = do
  !newattr <- setField' widget sfield fval
  let pairs = toPairs newattr
  unless (null pairs) $ widgetSendUpdate widget (object pairs)

-- | Change the value of a field, without notifying the frontend. For internal use.
setField' :: (f ∈ WidgetFields w, IHaskellWidget (IPythonWidget w))
          => IPythonWidget w -> SField f -> FieldType f -> IO (Attr f)
setField' widget sfield val = do
  attr <- getAttr widget sfield
  newval <- _verify attr val
  let newattr = attr { _value = Real newval }
  modifyIORef (state widget) (WidgetState . rput newattr . _getState)
  return newattr

-- | Pluck an attribute from a record
getAttr :: (f ∈ WidgetFields w) => IPythonWidget w -> SField f -> IO (Attr f)
getAttr widget sfield = rget sfield <$> _getState <$> readIORef (state widget)

-- | Get the value of a field.
getField :: (f ∈ WidgetFields w) => IPythonWidget w -> SField f -> IO (FieldType f)
getField widget sfield = unwrap . _value <$> getAttr widget sfield

-- | Useful with toJSON and OverloadedStrings
str :: String -> String
str = id

properties :: IPythonWidget w -> IO ()
properties widget = do
  st <- readIORef $ state widget
  let convert :: Attr f -> Const Field f
      convert attr = Const { getConst = _field attr }
  mapM_ print $ recordToList . rmap convert . _getState $ st

-- Helper function for widget to enforce their inability to fetch console input
noStdin :: IO a -> IO ()
noStdin action =
  let handler :: IOException -> IO ()
      handler e = when (ioeGetErrorType e == InvalidArgument)
                    (error "Widgets cannot do console input, sorry :)")
  in Ex.handle handler $ do
    nullFd <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags
    oldStdin <- dup stdInput
    void $ dupTo nullFd stdInput
    closeFd nullFd
    void action
    void $ dupTo oldStdin stdInput

-- Trigger events
triggerEvent :: (FieldType f ~ IO (), f ∈ WidgetFields w) => SField f -> IPythonWidget w -> IO ()
triggerEvent sfield w = noStdin . join $ getField w sfield

triggerChange :: (S.ChangeHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerChange = triggerEvent ChangeHandler

triggerClick :: (S.ClickHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerClick = triggerEvent ClickHandler

triggerSelection :: (S.SelectionHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerSelection = triggerEvent SelectionHandler

triggerSubmit :: (S.SubmitHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerSubmit = triggerEvent SubmitHandler

triggerDisplay :: (S.DisplayHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
triggerDisplay = triggerEvent DisplayHandler