{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}

module Trivmix.Types
       ( Level
       , toFloat
       , Adjustment(..)
       , doAdjustment
       , module Data.Default
       ) where

import Data.Fixed
import           Data.CaseInsensitive  ( CI )
import qualified Data.CaseInsensitive as CI

import Data.Default

import Data.Function (on)

data Level = Lin Float | DB Float

instance Num Level where
  (+) = asFloat (+)
  (-) = asFloat (-)
  (*) = asFloat (*)
  abs = Lin . abs . toFloat
  signum = Lin . signum . toFloat
  fromInteger = Lin . fromInteger

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

toFloat :: Level -> Float
toFloat (Lin x) = x
toFloat (DB x) = x

withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b
withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p')

withType :: (p a -> f a) -> f a
withType f = f undefined

withResolution :: (HasResolution a) => (Integer -> f a) -> f a
withResolution f = withType (f . resolution)

linToDb :: Float -> Float
linToDb x = 10 ** (0.05 * x)

dBToLin :: Float -> Float
dBToLin x = 20 * (logBase 10 x)

instance Show Level where
  show (Lin x) = show x
  show (DB x) = (show $ (withPrec x' :: Milli)) ++ "dB"
    where
      x' = dBToLin x

instance Read Level where
  readsPrec i = map toL . readsPrec i
    where
      toL :: (Float, String) -> (Level, String)
      toL (f, str)
        | ((==) `on` CI.mk) prec unit = (DB $ linToDb f, rest)
        | otherwise = (Lin f, str)
        where
          prec = take lU str
          rest = drop lU str
          unit = "dB"
          lU = length unit

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

instance Default Level where
  def = Lin 0

data Adjustment a = Set a
                  | Add a
                  | Sub a
                  deriving (Show, Eq)

class Adjustable a where
  add :: a -> a -> a
  sub :: a -> a -> a

-- instance Num a => Adjustable a where
--   add = (+)
--   sub = (-)

instance Adjustable Level where
  add (DB x) (DB y) = DB $ dBToLin $ ((+) `on` linToDb) x y
  add x y = x + y
  sub (DB x) (DB y) = DB $ dBToLin $ ((-) `on` linToDb) x y
  sub x y = x - y

doAdjustment :: Adjustable a => a -> Adjustment a -> a
doAdjustment _ (Set y) = y
doAdjustment x (Add y) = add x y
doAdjustment x (Sub y) = sub x y