Make MonoidValued functor implementation more strict

This improves running times slightly and may avoid space leaks that
arise from holding on to the labels-list for too long.

src/MA/Functors/Distribution.hs

@@ -47,8 +47,8 @@ instance ParseMorphism Distribution where
     return (h1, succs)
 
 instance RefinementInterface Distribution where
-  init _ _ = (0, 1)
-  update weightsToS (toRest, toC) =
+  init _ _ = MonoidWeight 0 1
+  update weightsToS (MonoidWeight toRest toC) =
     let
       toS = sum weightsToS
       toCwithoutS = toC - toS
@@ -58,4 +58,5 @@ instance RefinementInterface Distribution where
         then mkRes (toRest, toCwithoutS, toS)
         else mkRes (0, 0, 1)
     where
-      mkRes h3@(a, b, c) = ((a + b, c), h3, (a + c, b))
+      mkRes h3@(a, b, c) =
+        ( MonoidWeight (a + b) c, MonoidH3 a b c, MonoidWeight (a + c) b )

src/MA/Functors/MonoidValued.hs

@@ -11,6 +11,8 @@ module MA.Functors.MonoidValued
   ( intValued
   , realValued
   , MonoidValued(..)
+  , MonoidWeight(..)
+  , MonoidH3(..)
   ) where
 
 import           Control.Monad (when)
@@ -46,10 +48,14 @@ realValued :: FunctorParser (MonoidValued Double)
 realValued = prefix
   ((L.symbol "R" <|> L.symbol "ℝ") >> L.symbol "^" >> pure RealValued)
 
+data MonoidWeight m = MonoidWeight !m !m
+data MonoidH3 m = MonoidH3 !m !m !m
+  deriving (Eq, Ord, Show)
+
 type instance Label (MonoidValued m) = m
-type instance Weight (MonoidValued m) = (m, m)
+type instance Weight (MonoidValued m) = MonoidWeight m
 type instance H1 (MonoidValued m) = m
-type instance H3 (MonoidValued m) = (m, m, m)
+type instance H3 (MonoidValued m) = MonoidH3 m
 
 parseMorphismPointHelper ::
      (Num w, Ord x, MonadParser m)
@@ -77,16 +83,20 @@ instance ParseMorphism (MonoidValued Int) where
 instance ParseMorphism (MonoidValued Double) where
   parseMorphismPoint (RealValued inner) = parseMorphismPointHelper inner L.float
 
-instance (Num m, Ord m, Show m) => RefinementInterface (MonoidValued m) where
+instance (Num m, Ord m) => RefinementInterface (MonoidValued m) where
   init :: H1 (MonoidValued m) -> [Label (MonoidValued m)] -> Weight (MonoidValued m)
-  init _ weights = (0, sum weights)
+  init _ weights = MonoidWeight 0 (sum weights)
 
   update :: [Label (MonoidValued m)] -> Weight (MonoidValued m)
          -> (Weight (MonoidValued m), H3 (MonoidValued m), Weight (MonoidValued m))
-  update weightsToS (toRest, toC) =
+  update weightsToS (MonoidWeight toRest toC) =
     let
-      toS = sum weightsToS
-      toCwithoutS = toC - toS
-      toNotS = toRest + toCwithoutS
+      !toS = sum weightsToS
+      !toCwithoutS = toC - toS
+      !toNotS = toRest + toCwithoutS
+      !toNotC = toRest + toS
     in
-      ((toNotS, toS), (toRest, toCwithoutS, toS), (toRest + toS, toCwithoutS))
+      ( MonoidWeight toNotS toS
+      , MonoidH3 toRest toCwithoutS toS
+      , MonoidWeight toNotC toCwithoutS
+      )