Be somewhat stickyHEADmaster

2 files changed, 25 insertions, 3 deletions

diff --git a/src/Refined/AEq.hs b/src/Refined/AEq.hs
new file mode 100644
index 0000000..0a60679
--- /dev/null
+++ b/src/Refined/AEq.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Refined.AEq where
+
+import Data.AEq
+import Refined
+
+import Data.Function (on)
+
+instance AEq a => AEq (Refined p a) where
+  (===) = (===) `on` unrefine
+  (~==) = (~==) `on` unrefine
diff --git a/src/Trivmix/Types.hs b/src/Trivmix/Types.hs
index 5e4660d..347be8e 100644
--- a/src/Trivmix/Types.hs
+++ b/src/Trivmix/Types.hs
@@ -26,12 +26,16 @@ import Data.Default
 import Data.Function (on)
 
 import Refined
+import Data.AEq
 
 import Data.Scientific
 import Data.Scientific.Lift
 
+import Refined.AEq
+
 
 type Level' = Refined NonNegative Scientific
+
 data Level = Lin { toLin :: Level' } | DB { toLin :: Level' }
 
 instance Num Level where
@@ -43,7 +47,7 @@ instance Num Level where
   fromInteger = Lin . either error id . refine . fromInteger
 
 asScientific :: (Scientific -> Scientific -> Scientific) -> Level -> Level -> Either String Level
-asScientific ((`on` toScientific) -> f) x y = toLvl <$> refine (f x y)
+asScientific ((`on` toScientific) -> f) x y = toLvl <$> refineSticky (f x y)
   where
     toLvl
       | DB _ <- x = DB
@@ -66,7 +70,13 @@ linToDb :: Level' -> Scientific
 linToDb (unrefine -> x) = realToFrac (20 * (logBase 10 $ toRealFloat x) :: Double)
 
 dBToLin :: Scientific -> Level'
-dBToLin x = either error id . refine . realToFrac $ (10 ** (0.05 * toRealFloat x) :: Double)
+dBToLin x = either error id . refineSticky . realToFrac $ (10 ** (0.05 * toRealFloat x) :: Double)
+
+refineSticky :: Scientific -> Either String Level'
+refineSticky sc@(toRealFloat -> f)
+  | f ~== (1 :: Float) = Right ($$(refineTH 1) :: Level')
+  | f ~== (0 :: Float) = Right ($$(refineTH 0) :: Level')
+  | otherwise = refine sc
 
 instance Show Level where
   show (Lin (unrefine -> x)) = show x
@@ -84,7 +94,7 @@ instance Read Level where
         return . DB $ dBToLin db
       parseLin = do
         lin <- readS_to_Prec readsPrec
-        either (const mzero) (return . Lin) $ refine lin
+        either (const mzero) (return . Lin) $ refineSticky lin
 
 instance Eq Level where
   (==) = (==) `on` toLin