Merge branch 'master' of github.com:gibiansky/IHaskell

build.sh

@@ -73,7 +73,9 @@ INSTALL_DIRS=`echo $INSTALLS | tr ' ' '\n' | sed 's#^#./#' | tr ' ' '\n'`
 echo CMD: cabal install --constraint "arithmoi -llvm" -j $INSTALL_DIRS --force-reinstalls --max-backjumps=-1 --reorder-goals
 cabal install --constraint "arithmoi -llvm" -j $INSTALL_DIRS --force-reinstalls --max-backjumps=-1 --reorder-goals
 
-if [ ! $2 = "no-widgets" ] && { [ $1 = "display" ] || [ $1 = "all" ]; } then
+if [ $2 = "no-widgets" ]; then
+    echo 'Not installing ihaskell-widgets'
+elif [ $1 = "display" ] || [ $1 = "all" ]; then
     cabal install ihaskell-display/ihaskell-widgets
 fi
 

ihaskell-display/ihaskell-widgets/ihaskell-widgets.cabal

@@ -52,7 +52,8 @@ cabal-version:       >=1.10
 library
   -- Modules exported by the library.
   exposed-modules:     IHaskell.Display.Widgets
-  
+                       IHaskell.Display.Widgets.Interactive
+
   -- Modules included in this library but not exported.
   other-modules:       IHaskell.Display.Widgets.Button
                        IHaskell.Display.Widgets.Box.Box

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Interactive.hs

+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+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.Derived (HList)
+import           Data.Vinyl.Lens (type (∈))
+import           Data.Vinyl.TypeLevel (RecAll)
+
+import           IHaskell.Display
+
+import           IHaskell.Display.Widgets.Types
+import           IHaskell.Display.Widgets.Common
+import qualified IHaskell.Display.Widgets.Singletons as S (SField(..), Field(..))
+
+import           IHaskell.Display.Widgets.Box.FlexBox
+import           IHaskell.Display.Widgets.Bool.CheckBox
+import           IHaskell.Display.Widgets.String.Text
+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
+
+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)
+
+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
+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
+
+-- Zipping vinyl records in various ways
+applyGetters :: Rec Getter ts -> Rec RequiredWidget ts -> IO (HList ts)
+applyGetters RNil RNil = return RNil
+applyGetters (Getter getter :& gs) (RequiredWidget widget :& ws) = do
+  val <- getter widget
+  rest <- applyGetters gs ws
+  return $ Identity val :& rest
+
+applyEventSetters :: Rec EventSetter ts -> Rec RequiredWidget ts -> IO () -> IO ()
+applyEventSetters RNil RNil _ = return ()
+applyEventSetters (EventSetter setter :& xs) (RequiredWidget widget :& ws) handler = do
+  setter widget handler
+  applyEventSetters xs ws handler
+
+setInitialValues :: Rec Initializer ts -> Rec RequiredWidget ts -> Rec Argument ts -> IO ()
+setInitialValues RNil RNil RNil = return ()
+setInitialValues (Initializer initializer :& fs) (RequiredWidget widget :& ws) (argument :& vs) = do
+  initializer widget argument
+  setInitialValues fs ws vs
+
+extractConstructor :: WidgetConf x -> Constructor x
+extractConstructor (WidgetConf wr) = Constructor $ construct wr
+
+extractGetter :: WidgetConf x -> Getter x
+extractGetter (WidgetConf wr) = Getter $ getValue wr
+
+extractEventSetter :: WidgetConf x -> EventSetter x
+extractEventSetter (WidgetConf wr) = EventSetter $ setEvent wr
+
+extractTrigger :: WidgetConf x -> Trigger x
+extractTrigger (WidgetConf wr) = Trigger $ trigger wr
+
+extractInitializer :: WidgetConf x -> Initializer x
+extractInitializer (WidgetConf wr) = Initializer initializer
+
+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
+
+class MakeConfs (ts :: [*]) where
+  mkConfs :: proxy ts -> Rec WidgetConf ts
+
+instance MakeConfs '[] where
+  mkConfs _ = RNil
+
+instance (FromWidget t, MakeConfs ts) => MakeConfs (t ': ts) where
+  mkConfs _ = WidgetConf wrapped :& mkConfs (Proxy :: Proxy ts)
+
+interactive :: (IHaskellDisplay r, MakeConfs ts)
+            => (HList ts -> r) -> Rec Argument ts -> IO FlexBox
+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
+liftToWidgets :: IHaskellDisplay r
+              => (HList ts -> r) -> Rec WidgetConf ts -> Rec Argument ts -> IO FlexBox
+liftToWidgets func rc initvals = do
+  let constructors = rmap extractConstructor rc
+      getters = rmap extractGetter rc
+      eventSetters = rmap extractEventSetter rc
+      initializers = rmap extractInitializer rc
+      triggers = rmap extractTrigger rc
+
+  bx <- mkFlexBox
+  out <- mkOutputWidget
+
+  -- Create a list of widgets
+  widgets <- rtraverse createWidget constructors
+
+  let handler = do
+        vals <- applyGetters getters widgets
+        replaceOutput out $ func vals
+
+  -- Apply handler to all widgets
+  applyEventSetters eventSetters widgets handler
+
+  -- Set initial values for all widgets
+  setInitialValues initializers widgets initvals
+  -- applyValueSetters valueSetters widgets $ getList defvals
+
+  setField out Width 500
+  setField bx Orientation VerticalOrientation
+
+  -- Set children for the FlexBox
+  let children = mkChildren widgets
+  setField bx Children $ children ++ [ChildWidget out]
+
+  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
+
+construct :: WrappedWidget w h f a -> IO (IPythonWidget w)
+construct (WrappedWidget cons _ _) = cons
+
+getValue :: WrappedWidget w h f a -> IPythonWidget w -> IO a
+getValue (WrappedWidget _ _ field) widget = getField widget field
+
+setValue :: WrappedWidget w h f a -> IPythonWidget w -> a -> IO ()
+setValue (WrappedWidget _ _ field) widget = setField widget field
+
+setEvent :: WrappedWidget w h f a -> IPythonWidget w -> IO () -> IO ()
+setEvent (WrappedWidget _ h _) widget = setField widget h
+
+trigger :: WrappedWidget w h f a -> IPythonWidget w -> IO ()
+trigger (WrappedWidget _ h _) = triggerEvent h
+
+class RecAll Attr (WidgetFields (SuitableWidget a)) ToPairs => FromWidget a where
+  type SuitableWidget a :: WidgetType
+  type SuitableHandler a :: S.Field
+  type SuitableField a :: S.Field
+  data Argument a
+  initializer :: IPythonWidget (SuitableWidget a) -> Argument a -> IO ()
+  wrapped :: WrappedWidget (SuitableWidget a) (SuitableHandler a) (SuitableField a) a
+
+instance FromWidget Bool where
+  type SuitableWidget Bool = CheckBoxType
+  type SuitableHandler Bool = S.ChangeHandler
+  type SuitableField Bool = S.BoolValue
+  data Argument Bool = BoolVal Bool
+  initializer w (BoolVal b) = setField w BoolValue b
+  wrapped = WrappedWidget mkCheckBox ChangeHandler BoolValue
+
+instance FromWidget Text where
+  type SuitableWidget Text = TextType
+  type SuitableHandler Text = S.SubmitHandler
+  type SuitableField Text = S.StringValue
+  data Argument Text = TextVal Text
+  initializer w (TextVal txt) = setField w StringValue txt
+  wrapped = WrappedWidget mkTextWidget SubmitHandler StringValue
+
+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)
+  wrapped = WrappedWidget mkIntSlider ChangeHandler IntValue
+  initializer w (IntVal int) = setField w IntValue int
+  initializer w (IntRange (v, l, u)) = do
+    setField w IntValue v
+    setField w MinInt l
+    setField w MaxInt u
+
+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)
+  wrapped = WrappedWidget mkFloatSlider ChangeHandler FloatValue
+  initializer w (FloatVal d) = setField w FloatValue d
+  initializer w (FloatRange (v, l, u)) = do
+    setField w FloatValue v
+    setField w MinFloat l
+    setField w MaxFloat u

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Types.hs

@@ -380,6 +380,7 @@ rangeCheck (l, u) x
   | l <= x && x <= u = return x
   | l > x = Ex.throw Ex.Underflow
   | u < x = Ex.throw Ex.Overflow
+  | otherwise = error "The impossible happened in IHaskell.Display.Widgets.Types.rangeCheck"
 
 -- | Store a numeric value, with verification mechanism for its range.
 ranged :: (SingI f, Num (FieldType f), Ord (FieldType f))

verify_formatting.py

@@ -52,9 +52,9 @@ for source_dir in ["src", "ipython-kernel", "ihaskell-display"]:
 
         for filename in filenames:
             if "ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets" in root:
-                # Ignore Types.hs and Common.hs from ihaskell-widgets
+                # Ignoring files from ihaskell-widgets
                 # They cause issues with hindent, due to promoted types
-                ignored_files = ["Types.hs", "Common.hs", "Singletons.hs"]
+                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