Fix WidgetModel/Serialise instances. Add more tests.

src/Monomer/Core/WidgetModel.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleInstances #-}
 
 module Monomer.Core.WidgetModel where
@@ -5,6 +6,7 @@ module Monomer.Core.WidgetModel where
 import Codec.CBOR.Decoding
 import Codec.CBOR.Encoding
 import Codec.Serialise
+import Data.Bifunctor
 import Data.ByteString.Lazy (ByteString)
 import Data.Int
 import Data.Text (Text)
@@ -27,14 +29,41 @@ bsToSerialiseModel bs = case deserialiseOrFail bs of
   Right val -> Right val
   Left err -> Left (show err)
 
+traversableToSerialiseModel
+  :: (Traversable t, Serialise (t ByteString), WidgetModel s)
+  => ByteString
+  -> Either String (t s)
+traversableToSerialiseModel tr = case deserialiseOrFail tr of
+  Right val -> traverse byteStringToModel val
+  Left err -> Left (show err)
+
 instance WidgetModel a => WidgetModel (Maybe a) where
   modelToByteString val = serialise (modelToByteString <$> val)
-  byteStringToModel bs = deserialise bs >>= byteStringToModel
+  byteStringToModel = traversableToSerialiseModel
+
+instance (WidgetModel a, WidgetModel b) => WidgetModel (Either a b) where
+  modelToByteString val = serialise (bimap modelToByteString modelToByteString val)
+  byteStringToModel bs = case deserialiseOrFail bs of
+    Right (Right val) -> Right <$> byteStringToModel val
+    Right (Left val) -> Left <$> byteStringToModel val
+    Left err -> Left (show err)
+
+instance WidgetModel a => WidgetModel [a] where
+  modelToByteString val = serialise (modelToByteString <$> val)
+  byteStringToModel = traversableToSerialiseModel
 
 instance WidgetModel () where
   modelToByteString = serialise
   byteStringToModel = bsToSerialiseModel
 
+instance WidgetModel Bool where
+  modelToByteString = serialise
+  byteStringToModel = bsToSerialiseModel
+
+instance WidgetModel Char where
+  modelToByteString = serialise
+  byteStringToModel = bsToSerialiseModel
+
 instance WidgetModel Integer where
   modelToByteString = serialise
   byteStringToModel = bsToSerialiseModel

src/Monomer/Widgets/Composite.hs

@@ -173,8 +173,8 @@ instance WidgetModel s => Serialise (CompositeState s e) where
   decode = do
     len <- decodeListLen
     tag <- decodeWord
-    modelBS <- decodeBytes
-    let model = fromRight Nothing (byteStringToModel (BSL.fromStrict modelBS))
+    modelBS <- decode
+    let model = fromRight Nothing (byteStringToModel modelBS)
     case (len, tag) of
       (2, 0) -> return $ CompositeState model spacer M.empty
       _ -> fail "Invalid Composite state"

src/Monomer/Widgets/InputField.hs

@@ -30,7 +30,7 @@ import Monomer.Widgets.Single
 
 import qualified Monomer.Lens as L
 
-type InputFieldValue a = (Eq a, Show a, Typeable a, WidgetModel a, Serialise a)
+type InputFieldValue a = (Eq a, Show a, Typeable a, Serialise a)
 
 type InputDragHandler a
   = InputFieldState a

src/Monomer/Widgets/ListView.hs

@@ -164,7 +164,8 @@ data ListViewState a = ListViewState {
 
 instance Serialise (ListViewState a) where
   encode ListViewState{..} = encodeListLen 5 <> encodeTag 0
-    <> encode _slIdx <> encode _hlIdx <> encode _slStyle <> encode _hlStyle
+    <> encode _slIdx <> encode _hlIdx
+    <> encode _slStyle <> encode _hlStyle
     <> encode _resizeReq
   decode = do
     len <- decodeListLen

src/Monomer/Widgets/NumericField.hs

@@ -37,7 +37,7 @@ import Monomer.Widgets.Util
 import qualified Monomer.Lens as L
 
 type FormattableNumber a
-  = (Eq a, Show a, Typeable a, Real a, FromFractional a, WidgetModel a, Serialise a)
+  = (Eq a, Show a, Typeable a, Real a, FromFractional a, Serialise a)
 
 data NumericFieldCfg s e a = NumericFieldCfg {
   _nfcValid :: Maybe (WidgetData s Bool),

tasks.md

@@ -474,6 +474,8 @@
   - Add option to avoid adding styles (Container)
   - Return widgetInfo instead of just path in widgetFindByPoint
   - Add widgetFindByPath
+  - Do something about Serialise. Temporarily hide from composite?
+    - Added WidgetModel typeclass. Provides a way of not forcing users to implement Serialise
 
 - Pending
   - Add header in all files, indicating license and documenting what the module does
@@ -493,8 +495,6 @@
     - https://stackoverflow.com/questions/51275681/how-to-include-a-dependency-c-library-in-haskell-stack
 
 Maybe postponed after release?
-  - Do something about Serialise. Temporarily hide from composite?
-    - Check Serialise requirement on InputField
   - Improve test utilities
     - Some way to combine them, avoid this noInit thing, losing of focus, etc
     - Test image updating WidgetId/Path

test/unit/Monomer/Widgets/PersistSpec.hs

@@ -45,15 +45,11 @@ data ChildEvt
   | ChildMessage String
   deriving (Eq, Show)
 
-newtype MainModel = MainModel {
-  _tmText1 :: Text
+data MainModel = MainModel {
+  _tmText1 :: Text,
+  _tmCount1 :: Int
 } deriving (Eq, Show, Generic, Serialise)
 
-instance Default MainModel where
-  def = MainModel {
-    _tmText1 = ""
-  }
-
 instance WidgetModel MainModel where
   modelToByteString = serialise
   byteStringToModel = bsToSerialiseModel
@@ -64,11 +60,27 @@ setFontColorL = L.text . non def . L.fontColor
 
 spec :: Spec
 spec = describe "Persist" $ do
+  widgetModel
   saveSingle
   restoreSingle
   restoreContainer
   restoreComposite
 
+widgetModel :: Spec
+widgetModel = describe "widgetModel" $ do
+  it "should return the same value" $ do
+    byteStringToModel textBS `shouldBe` Right ("Text" :: Text)
+    byteStringToModel maybeBS `shouldBe` Right (Just 10 :: Maybe Rational)
+    byteStringToModel listBS `shouldBe` Right ([1, 2, 3] :: [Int])
+    byteStringToModel rightBS `shouldBe` Right (Right 20 :: Either Int Int)
+    byteStringToModel leftBS `shouldBe` Right (Left 30 :: Either Int Int)
+  where
+    textBS = modelToByteString ("Text" :: Text)
+    maybeBS = modelToByteString (Just 10 :: Maybe Rational)
+    listBS = modelToByteString ([1, 2, 3] :: [Int])
+    rightBS = modelToByteString (Right 20 :: Either Int Int)
+    leftBS = modelToByteString (Left 30 :: Either Int Int)
+
 saveSingle :: Spec
 saveSingle = describe "saveSingle" $ do
   it "should have same info" $
@@ -91,9 +103,11 @@ restoreSingle = describe "restoreSingle" $ do
   it "should have same info" $ do
     oldInfo `shouldBe` rstInfo
     model2 ^. text1 `shouldBe` "Test restore"
+    model2 ^. count1 `shouldBe` 0
+
   where
     wenv :: WidgetEnv MainModel ()
-    wenv = mockWenv (MainModel "Test")
+    wenv = mockWenv (MainModel "Test" 10)
     node1 = textField text1
     (model2, oldInfo, rstInfo) = handleRestoredEvents wenv node1
 
@@ -102,9 +116,10 @@ restoreContainer = describe "restoreContainer" $ do
   it "should have same info" $ do
     oldInfo `shouldBe` rstInfo
     model2 ^. text1 `shouldBe` "Test restore"
+    model2 ^. count1 `shouldBe` 0
 
   where
-    wenv = mockWenv (MainModel "Test")
+    wenv = mockWenv (MainModel "Test" 10)
     node1 = vstack [
         textField text1
       ]
@@ -115,9 +130,10 @@ restoreComposite = describe "restoreComposite" $ do
   it "should have same info" $ do
     oldInfo `shouldBe` rstInfo
     model2 ^. text1 `shouldBe` "Test restore"
+    model2 ^. count1 `shouldBe` 10
 
   where
-    wenv = mockWenv (MainModel "Test")
+    wenv = mockWenv (MainModel "Test" 10)
     handleEvent
       :: WidgetEnv MainModel MainEvt
       -> WidgetNode MainModel MainEvt
@@ -136,7 +152,8 @@ handleRestoredEvents wenv node1 = (model2, oldInfo, rstInfo) where
   newNode = node1 `style` [textColor red]
   inst1 = widgetSave (oldNode ^. L.widget) wenv oldNode
   inst2 = deserialise (serialise inst1)
-  ((wenv2, node2, reqs2, evts2), ctx) = nodeHandleRestore wenv inst2 newNode
+  wenvRest = mockWenv (MainModel "Test" 0)
+  ((wenv2, node2, reqs2, evts2), ctx) = nodeHandleRestore wenvRest inst2 newNode
   model2 = nodeHandleEventModelNoInit wenv2 [evtK keyTab, evtT " restore"] node2
   oldStyle = setStyleValue (oldNode ^. L.info . L.style) setFontColorL (?~) red
   oldInfo = oldNode ^. L.info