Implement balance & refine types

1 files changed, 42 insertions, 37 deletions

diff --git a/src/Trivmix/Types.hs b/src/Trivmix/Types.hs
index a6a41b9..f01e023 100644
--- a/src/Trivmix/Types.hs
+++ b/src/Trivmix/Types.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances, ViewPatterns, TemplateHaskell, PatternGuards #-}
 
 module Trivmix.Types
-       ( Level
+       ( Level'
+       , Level(Lin), toLin
        , toFloat
        , asFloat
        , Adjustment(..)
@@ -13,27 +14,37 @@ import Data.Fixed
 import           Data.CaseInsensitive  ( CI )
 import qualified Data.CaseInsensitive as CI
 
+import Text.ParserCombinators.ReadPrec
+import Control.Applicative
+import Control.Monad
+
 import Data.Default
 
 import Data.Function (on)
 
-data Level = Lin Float | DB Float
+import Refined
 
-instance Num Level where
-  (+) = asFloat (+)
-  (-) = asFloat (-)
-  (*) = asFloat (*)
-  abs = Lin . abs . toFloat
-  signum = Lin . signum . toFloat
-  fromInteger = Lin . fromInteger
+type Level' = Refined NonNegative Float
+data Level = Lin { toLin :: Level' } | DB { toLin :: Level' }
 
-asFloat :: (Float -> Float -> Float) -> Level -> Level -> Level
-asFloat f (Lin x) (Lin y) = Lin $ f x y
-asFloat f x y = DB $ (f `on` toFloat) x y
+instance Num Level where
+  (+) = fmap (either error id) . asFloat (+)
+  (-) = fmap (either error id) . asFloat (-)
+  (*) = fmap (either error id) . asFloat (*)
+  abs = Lin . toLin
+  signum = Lin . either error id . refine . signum . toFloat
+  fromInteger = Lin . either error id . refine . fromInteger
+
+asFloat :: (Float -> Float -> Float) -> Level -> Level -> Either String Level
+asFloat ((`on` toFloat) -> f) x y = toLvl <$> refine (f x y)
+  where
+    toLvl
+      | DB _ <- x = DB
+      | DB _ <- y = DB
+      | otherwise = Lin
 
 toFloat :: Level -> Float
-toFloat (Lin x) = x
-toFloat (DB x) = x
+toFloat = unrefine . toLin
 
 withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b
 withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p')
@@ -44,39 +55,33 @@ withType f = f undefined
 withResolution :: (HasResolution a) => (Integer -> f a) -> f a
 withResolution f = withType (f . resolution)
 
-linToDb :: Float -> Float
-linToDb x = 20 * (logBase 10 x)
+linToDb :: Level' -> Float
+linToDb (unrefine -> x) = 20 * (logBase 10 x)
 
-dBToLin :: Float -> Float
-dBToLin x = 10 ** (0.05 * x)
+dBToLin :: Float -> Level'
+dBToLin x = either error id . refine $ 10 ** (0.05 * x)
 
 instance Show Level where
   show (Lin x) = show x
-  show (DB x) = (show $ (withPrec x' :: Milli)) ++ "dB"
-    where
-      x' = linToDb x
+  show (DB (linToDb -> x)) = (show $ (withPrec x :: Milli)) ++ "dB"
 
 instance Read Level where
-  readsPrec i = map toL . readsPrec i
+  readsPrec = readPrec_to_S $ parseDb <|> parseLin
     where
-      toL :: (Float, String) -> (Level, String)
-      toL (f, str)
-        | ((==) `on` CI.mk) prec unit = (DB $ dBToLin f, rest)
-        | otherwise = (Lin f, str)
-        where
-          prec = take lU str
-          rest = drop lU str
-          unit = "dB"
-          lU = length unit
+      parseDb  = do
+        db <- readS_to_Prec readsPrec
+        let
+          unit@(length -> lU) = "dB"
+        unit' <- forM [1..lU] $ const get
+        guard $ ((==) `on` CI.mk) unit unit'
+        return . DB $ dBToLin db
+      parseLin = Lin <$> readS_to_Prec readsPrec
 
 instance Eq Level where
-  (Lin a) == (Lin b) = a == b
-  (Lin a) == (DB b) = a == b
-  (DB a) == (Lin b) = a == b
-  (DB a) == (DB b) = a == b
+  (==) = (==) `on` toLin
 
 instance Default Level where
-  def = Lin 0
+  def = Lin $$(refineTH 0)
 
 data Adjustment a = Set a
                   | Add a