From 62b6c556b03dcfd0130e765eacb8cf4af36cdd52 Mon Sep 17 00:00:00 2001 From: Andrew Gibiansky Date: Tue, 25 Aug 2015 16:54:05 -0700 Subject: [PATCH] Fix formatting with newer hindent --- Setup.hs | 3 +- ghc-parser/Setup.hs | 13 +- ihaskell-display/ihaskell-aeson/Setup.hs | 3 +- ihaskell-display/ihaskell-basic/Setup.hs | 3 +- ihaskell-display/ihaskell-blaze/Setup.hs | 3 +- ihaskell-display/ihaskell-charts/Setup.hs | 3 +- ihaskell-display/ihaskell-diagrams/Setup.hs | 3 +- ihaskell-display/ihaskell-hatex/Setup.hs | 3 +- .../ihaskell-juicypixels/Setup.hs | 3 +- ihaskell-display/ihaskell-magic/Setup.hs | 3 +- ihaskell-display/ihaskell-parsec/Setup.hs | 3 +- ihaskell-display/ihaskell-plot/Setup.hs | 3 +- ihaskell-display/ihaskell-rlangqq/Setup.hs | 3 +- .../ihaskell-static-canvas/Setup.hs | 3 +- ihaskell-display/ihaskell-widgets/Setup.hs | 3 +- .../src/IHaskell/Display/Widgets/Common.hs | 17 +- .../IHaskell/Display/Widgets/Interactive.hs | 83 +- .../IHaskell/Display/Widgets/Singletons.hs | 9 +- .../src/IHaskell/Display/Widgets/Types.hs | 858 +++++++++++------- src/IHaskell/Eval/Evaluate.hs | 26 +- verify_formatting.py | 11 +- 21 files changed, 649 insertions(+), 410 deletions(-) diff --git a/Setup.hs b/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ghc-parser/Setup.hs b/ghc-parser/Setup.hs index 6e577dc0..a5eeed77 100644 --- a/ghc-parser/Setup.hs +++ b/ghc-parser/Setup.hs @@ -1,8 +1,7 @@ -import Distribution.Simple -import System.Cmd +import Distribution.Simple +import System.Cmd -main = defaultMainWithHooks simpleUserHooks{ - preConf = \args confFlags -> do - system "./build-parser.sh" - preConf simpleUserHooks args confFlags -} +main = defaultMainWithHooks + simpleUserHooks { preConf = \args confFlags -> do + system "./build-parser.sh" + preConf simpleUserHooks args confFlags } diff --git a/ihaskell-display/ihaskell-aeson/Setup.hs b/ihaskell-display/ihaskell-aeson/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/ihaskell-display/ihaskell-aeson/Setup.hs +++ b/ihaskell-display/ihaskell-aeson/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-display/ihaskell-basic/Setup.hs b/ihaskell-display/ihaskell-basic/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/ihaskell-display/ihaskell-basic/Setup.hs +++ b/ihaskell-display/ihaskell-basic/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-display/ihaskell-blaze/Setup.hs b/ihaskell-display/ihaskell-blaze/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/ihaskell-display/ihaskell-blaze/Setup.hs +++ b/ihaskell-display/ihaskell-blaze/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-display/ihaskell-charts/Setup.hs b/ihaskell-display/ihaskell-charts/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/ihaskell-display/ihaskell-charts/Setup.hs +++ b/ihaskell-display/ihaskell-charts/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-display/ihaskell-diagrams/Setup.hs b/ihaskell-display/ihaskell-diagrams/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/ihaskell-display/ihaskell-diagrams/Setup.hs +++ b/ihaskell-display/ihaskell-diagrams/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-display/ihaskell-hatex/Setup.hs b/ihaskell-display/ihaskell-hatex/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/ihaskell-display/ihaskell-hatex/Setup.hs +++ b/ihaskell-display/ihaskell-hatex/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-display/ihaskell-juicypixels/Setup.hs b/ihaskell-display/ihaskell-juicypixels/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/ihaskell-display/ihaskell-juicypixels/Setup.hs +++ b/ihaskell-display/ihaskell-juicypixels/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-display/ihaskell-magic/Setup.hs b/ihaskell-display/ihaskell-magic/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/ihaskell-display/ihaskell-magic/Setup.hs +++ b/ihaskell-display/ihaskell-magic/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-display/ihaskell-parsec/Setup.hs b/ihaskell-display/ihaskell-parsec/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/ihaskell-display/ihaskell-parsec/Setup.hs +++ b/ihaskell-display/ihaskell-parsec/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-display/ihaskell-plot/Setup.hs b/ihaskell-display/ihaskell-plot/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/ihaskell-display/ihaskell-plot/Setup.hs +++ b/ihaskell-display/ihaskell-plot/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-display/ihaskell-rlangqq/Setup.hs b/ihaskell-display/ihaskell-rlangqq/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/ihaskell-display/ihaskell-rlangqq/Setup.hs +++ b/ihaskell-display/ihaskell-rlangqq/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-display/ihaskell-static-canvas/Setup.hs b/ihaskell-display/ihaskell-static-canvas/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/ihaskell-display/ihaskell-static-canvas/Setup.hs +++ b/ihaskell-display/ihaskell-static-canvas/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-display/ihaskell-widgets/Setup.hs b/ihaskell-display/ihaskell-widgets/Setup.hs index 9a994af6..ebdc00e6 100644 --- a/ihaskell-display/ihaskell-widgets/Setup.hs +++ b/ihaskell-display/ihaskell-widgets/Setup.hs @@ -1,2 +1,3 @@ -import Distribution.Simple +import Distribution.Simple + main = defaultMain diff --git a/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Common.hs b/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Common.hs index 2cd3c2ea..fdd6b06a 100644 --- a/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Common.hs +++ b/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Common.hs @@ -4,14 +4,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} + module IHaskell.Display.Widgets.Common where -import Data.Aeson -import Data.Aeson.Types (emptyObject) -import Data.Text (pack, Text) +import Data.Aeson +import Data.Aeson.Types (emptyObject) +import Data.Text (pack, Text) -import IHaskell.Display (IHaskellWidget) -import IHaskell.Eval.Widgets (widgetSendClose) +import IHaskell.Display (IHaskellWidget) +import IHaskell.Eval.Widgets (widgetSendClose) import qualified IHaskell.Display.Widgets.Singletons as S @@ -91,7 +92,8 @@ pattern SelectedIndex = S.SSelectedIndex closeWidget :: IHaskellWidget w => w -> IO () closeWidget w = widgetSendClose w emptyObject -newtype StrInt = StrInt Integer deriving (Num, Ord, Eq, Enum) +newtype StrInt = StrInt Integer + deriving (Num, Ord, Eq, Enum) instance ToJSON StrInt where toJSON (StrInt x) = toJSON . pack $ show x @@ -205,7 +207,8 @@ instance ToJSON ImageFormatValue where toJSON = toJSON . pack . show -- | Options for selection widgets. -data SelectionOptions = OptionLabels [Text] | OptionDict [(Text, Text)] +data SelectionOptions = OptionLabels [Text] + | OptionDict [(Text, Text)] -- | Orientation values. data OrientationValue = HorizontalOrientation diff --git a/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Interactive.hs b/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Interactive.hs index fa3c5781..dd03ec85 100644 --- a/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Interactive.hs +++ b/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Interactive.hs @@ -10,18 +10,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternSynonyms #-} -module IHaskell.Display.Widgets.Interactive ( - interactive, - uncurryHList, - Rec (..), - Argument (..), - ) where +module IHaskell.Display.Widgets.Interactive (interactive, uncurryHList, Rec(..), Argument(..)) where import Data.Text import Data.Proxy import Data.Vinyl.Core -import Data.Vinyl.Functor (Identity (..), Const (..)) +import Data.Vinyl.Functor (Identity(..), Const(..)) import Data.Vinyl.Derived (HList) import Data.Vinyl.Lens (type (∈)) import Data.Vinyl.TypeLevel (RecAll) @@ -39,35 +34,49 @@ import IHaskell.Display.Widgets.Int.BoundedInt.IntSlider import IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider import IHaskell.Display.Widgets.Output + data WidgetConf a where - WidgetConf :: (RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs, FromWidget a) - => WrappedWidget (SuitableWidget a) (SuitableHandler a) (SuitableField a) a - -> WidgetConf a + WidgetConf :: + (RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs, + FromWidget a) => + WrappedWidget (SuitableWidget a) (SuitableHandler a) + (SuitableField a) + a + -> WidgetConf a -newtype WrappedConstructor a = WrappedConstructor { - wrappedConstructor :: IO (IPythonWidget (SuitableWidget a)) -} +newtype WrappedConstructor a = + WrappedConstructor + { wrappedConstructor :: IO (IPythonWidget (SuitableWidget a)) } + type family WithTypes (ts :: [*]) (r :: *) :: * where - WithTypes '[] r = r - WithTypes (x ': xs) r = (x -> WithTypes xs r) + WithTypes '[] r = r + WithTypes (x ': xs) r = (x -> WithTypes xs r) uncurryHList :: WithTypes ts r -> HList ts -> r uncurryHList f RNil = f uncurryHList f (Identity x :& xs) = uncurryHList (f x) xs -- Consistent type variables are required to make things play nicely with vinyl + data Constructor a where - Constructor :: RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs - => IO (IPythonWidget (SuitableWidget a)) -> Constructor a + Constructor :: + RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs => + IO (IPythonWidget (SuitableWidget a)) -> Constructor a + newtype Getter a = Getter (IPythonWidget (SuitableWidget a) -> IO a) + newtype EventSetter a = EventSetter (IPythonWidget (SuitableWidget a) -> IO () -> IO ()) + newtype Initializer a = Initializer (IPythonWidget (SuitableWidget a) -> Argument a -> IO ()) + newtype Trigger a = Trigger (IPythonWidget (SuitableWidget a) -> IO ()) + + data RequiredWidget a where - RequiredWidget :: RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs - => IPythonWidget (SuitableWidget a) - -> RequiredWidget a + RequiredWidget :: + RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs => + IPythonWidget (SuitableWidget a) -> RequiredWidget a -- Zipping vinyl records in various ways applyGetters :: Rec Getter ts -> Rec RequiredWidget ts -> IO (HList ts) @@ -108,8 +117,9 @@ createWidget :: Constructor a -> IO (RequiredWidget a) createWidget (Constructor con) = fmap RequiredWidget con mkChildren :: Rec RequiredWidget a -> [ChildWidget] -mkChildren widgets = let childRecord = rmap (\(RequiredWidget w) -> Const (ChildWidget w)) widgets - in recordToList childRecord +mkChildren widgets = + let childRecord = rmap (\(RequiredWidget w) -> Const (ChildWidget w)) widgets + in recordToList childRecord class MakeConfs (ts :: [*]) where mkConfs :: proxy ts -> Rec WidgetConf ts @@ -122,13 +132,13 @@ instance (FromWidget t, MakeConfs ts) => MakeConfs (t ': ts) where interactive :: (IHaskellDisplay r, MakeConfs ts) => (HList ts -> r) -> Rec Argument ts -> IO FlexBox -interactive func = let confs = mkConfs Proxy - in liftToWidgets func confs +interactive func = + let confs = mkConfs Proxy + in liftToWidgets func confs --- | Transform a function (HList ts -> r) to one which: --- 1) Uses widgets to accept the arguments --- 2) Accepts initial values for the arguments --- 3) Creates a compound FlexBox widget with an embedded OutputWidget for display +-- | Transform a function (HList ts -> r) to one which: 1) Uses widgets to accept the arguments 2) +-- Accepts initial values for the arguments 3) Creates a compound FlexBox widget with an embedded +-- OutputWidget for display liftToWidgets :: IHaskellDisplay r => (HList ts -> r) -> Rec WidgetConf ts -> Rec Argument ts -> IO FlexBox liftToWidgets func rc initvals = do @@ -154,7 +164,6 @@ liftToWidgets func rc initvals = do -- Set initial values for all widgets setInitialValues initializers widgets initvals -- applyValueSetters valueSetters widgets $ getList defvals - setField out Width 500 setField bx Orientation VerticalOrientation @@ -164,10 +173,14 @@ liftToWidgets func rc initvals = do return bx + data WrappedWidget w h f a where - WrappedWidget :: (FieldType h ~ IO (), FieldType f ~ a, h ∈ WidgetFields w, f ∈ WidgetFields w, - ToPairs (Attr h), IHaskellWidget (IPythonWidget w), ToPairs (Attr f)) - => IO (IPythonWidget w) -> S.SField h -> S.SField f -> WrappedWidget w h f a + WrappedWidget :: + (FieldType h ~ IO (), FieldType f ~ a, h ∈ WidgetFields w, + f ∈ WidgetFields w, ToPairs (Attr h), + IHaskellWidget (IPythonWidget w), ToPairs (Attr f)) => + IO (IPythonWidget w) -> + S.SField h -> S.SField f -> WrappedWidget w h f a construct :: WrappedWidget w h f a -> IO (IPythonWidget w) construct (WrappedWidget cons _ _) = cons @@ -212,7 +225,8 @@ instance FromWidget Integer where type SuitableWidget Integer = IntSliderType type SuitableHandler Integer = S.ChangeHandler type SuitableField Integer = S.IntValue - data Argument Integer = IntVal Integer | IntRange (Integer, Integer, Integer) + data Argument Integer = IntVal Integer + | IntRange (Integer, Integer, Integer) wrapped = WrappedWidget mkIntSlider ChangeHandler IntValue initializer w (IntVal int) = setField w IntValue int initializer w (IntRange (v, l, u)) = do @@ -224,7 +238,8 @@ instance FromWidget Double where type SuitableWidget Double = FloatSliderType type SuitableHandler Double = S.ChangeHandler type SuitableField Double = S.FloatValue - data Argument Double = FloatVal Double | FloatRange (Double, Double, Double) + data Argument Double = FloatVal Double + | FloatRange (Double, Double, Double) wrapped = WrappedWidget mkFloatSlider ChangeHandler FloatValue initializer w (FloatVal d) = setField w FloatValue d initializer w (FloatRange (v, l, u)) = do diff --git a/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Singletons.hs b/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Singletons.hs index ec5ddc10..279fad65 100644 --- a/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Singletons.hs +++ b/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Singletons.hs @@ -5,12 +5,15 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} + module IHaskell.Display.Widgets.Singletons where -import Data.Singletons.TH +import Data.Singletons.TH -- Widget properties -singletons [d| +singletons + [d| + data Field = ViewModule | ViewName | MsgThrottle @@ -83,4 +86,4 @@ singletons [d| | Titles | SelectedIndex deriving (Eq, Ord, Show) - |] + |] diff --git a/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Types.hs b/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Types.hs index 797a685f..91601038 100644 --- a/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Types.hs +++ b/ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Types.hs @@ -12,14 +12,16 @@ {-# 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. +-- 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. +-- 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'. -- @@ -29,157 +31,176 @@ module IHaskell.Display.Widgets.Types where -- 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. +-- 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. +-- 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@). +-- 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_", where @@ -- 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. +-- 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 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 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.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.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 Data.Singletons.Prelude ((:++)) +import Data.Singletons.TH -import IHaskell.Eval.Widgets (widgetSendUpdate) -import IHaskell.Display (Base64, IHaskellWidget (..)) -import IHaskell.IPython.Message.UUID +import IHaskell.Eval.Widgets (widgetSendUpdate) +import IHaskell.Display (Base64, IHaskellWidget(..)) +import IHaskell.IPython.Message.UUID -import IHaskell.Display.Widgets.Singletons (Field, SField (..)) +import IHaskell.Display.Widgets.Singletons (Field, SField(..)) import qualified IHaskell.Display.Widgets.Singletons as S -import IHaskell.Display.Widgets.Common +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 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 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 + 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) @@ -196,14 +217,14 @@ class CustomBounded a where -- Set according to what IPython widgets use instance CustomBounded StrInt where upperBound = 10 ^ 16 - 1 - lowerBound = - (10 ^ 16 - 1) + lowerBound = -(10 ^ 16 - 1) instance CustomBounded Integer where - lowerBound = - (10 ^ 16 - 1) + lowerBound = -(10 ^ 16 - 1) upperBound = 10 ^ 16 - 1 instance CustomBounded Double where - lowerBound = - (10 ** 16 - 1) + lowerBound = -(10 ** 16 - 1) upperBound = 10 ** 16 - 1 -- Different types of widgets. Every widget in IPython has a corresponding WidgetType @@ -237,38 +258,57 @@ data WidgetType = ButtonType | 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 + 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 +data AttrVal a = Dummy a + | Real a unwrap :: AttrVal a -> a unwrap (Dummy x) = x @@ -276,97 +316,241 @@ 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 - } + 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 + 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.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] + 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. @@ -391,166 +575,186 @@ ranged s range x = Attr x (rangeCheck range) (reflect s) -- 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) +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 +-- | 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 + :& (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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + where + selAttrs = (Titles =:: []) + :& (SelectedIndex =:: 0) + :& (ChangeHandler =:: return ()) + :& RNil newtype WidgetState w = WidgetState { _getState :: Rec Attr (WidgetFields w) } @@ -559,11 +763,15 @@ 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 + . 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) } +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)) diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs index cd746557..e18804c5 100644 --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -136,6 +136,7 @@ requiredGlobalImports = , "import qualified System.IO as IHaskellSysIO" , "import qualified Language.Haskell.TH as IHaskellTH" ] + ihaskellGlobalImports :: [String] ihaskellGlobalImports = [ "import IHaskell.Display()" @@ -146,7 +147,8 @@ ihaskellGlobalImports = -- | Run an interpreting action. This is effectively runGhc with initialization and importing. First -- argument indicates whether `stdin` is handled specially, which cannot be done in a testing --- environment. The argument passed to the action indicates whether Haskell support libraries are available. +-- environment. The argument passed to the action indicates whether Haskell support libraries are +-- available. interpret :: String -> Bool -> (Bool -> Interpreter a) -> IO a interpret libdir allowedStdin action = runGhc (Just libdir) $ do -- If we're in a sandbox, add the relevant package database @@ -177,8 +179,8 @@ packageIdString' dflags = packageKeyPackageIdString dflags #else packageIdString' dflags = packageIdString #endif --- | Initialize our GHC session with imports and a value for 'it'. --- Return whether the IHaskell support libraries are available. +-- | Initialize our GHC session with imports and a value for 'it'. Return whether the IHaskell +-- support libraries are available. initializeImports :: Interpreter Bool initializeImports = do -- Load packages that start with ihaskell-*, aren't just IHaskell, and depend directly on the right @@ -202,9 +204,9 @@ initializeImports = do guard (iHaskellPkgName `isPrefixOf` idString) displayPkgs = [pkgName | pkgName <- packageNames - , Just (x:_) <- [stripPrefix initStr pkgName] - , pkgName `notElem` broken - , isAlpha x] + , Just (x:_) <- [stripPrefix initStr pkgName] + , pkgName `notElem` broken + , isAlpha x] hasIHaskellPackage = not $ null $ filter (== iHaskellPkgName) packageNames @@ -228,8 +230,8 @@ initializeImports = do -- Import modules. imports <- mapM parseImportDecl $ requiredGlobalImports ++ if hasIHaskellPackage - then ihaskellGlobalImports ++ displayImports - else [] + then ihaskellGlobalImports ++ displayImports + else [] setContext $ map IIDecl $ implicitPrelude : imports -- Set -fcontext-stack to 100 (default in ghc-7.10). ghc-7.8 uses 20, which is too small. @@ -318,8 +320,8 @@ evaluate kernelState code output widgetHandler = do -- Get displayed channel outputs. Merge them with normal display outputs. dispsMay <- if supportLibrariesAvailable state - then extractValue "IHaskell.Display.displayFromChan" >>= liftIO - else return Nothing + then extractValue "IHaskell.Display.displayFromChan" >>= liftIO + else return Nothing let result = case dispsMay of Nothing -> evalResult evalOut @@ -336,8 +338,8 @@ evaluate kernelState code output widgetHandler = do -- Handle the widget messages newState <- if supportLibrariesAvailable state - then flushWidgetMessages tempState tempMsgs widgetHandler - else return tempState + then flushWidgetMessages tempState tempMsgs widgetHandler + else return tempState case evalStatus evalOut of Success -> runUntilFailure newState rest diff --git a/verify_formatting.py b/verify_formatting.py index 4624f6af..b266e3f2 100755 --- a/verify_formatting.py +++ b/verify_formatting.py @@ -44,21 +44,16 @@ except: # Find all the source files sources = [] +widget_dir = "ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets" for source_dir in ["src", "ipython-kernel", "ihaskell-display"]: for root, dirnames, filenames in os.walk(source_dir): # Skip cabal dist directories if "dist" in root: continue + # Ignore IHaskellPrelude.hs, it uses CPP in weird places + ignored_files = ["IHaskellPrelude.hs"] for filename in filenames: - if "ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets" in root: - # Ignoring files from ihaskell-widgets - # They cause issues with hindent, due to promoted types - ignored_files = ["Types.hs", "Common.hs", "Singletons.hs", "Interactive.hs"] - else: - # Take Haskell files, but ignore the Cabal Setup.hs - # Also ignore IHaskellPrelude.hs, it uses CPP in weird places - ignored_files = ["Setup.hs", "IHaskellPrelude.hs", "Evaluate.hs"] if filename.endswith(".hs") and filename not in ignored_files: sources.append(os.path.join(root, filename))