{-# LANGUAGE FlexibleInstances, UndecidableInstances, ViewPatterns, TemplateHaskell, PatternGuards #-}

module Trivmix.Types
       ( Level'
       , Level(Lin), toLin
       , toFloat
       , asFloat
       , Balance(..)
       , bToFloat
       , bAsFloat
       , Adjustment(..)
       , doAdjustment
       , module Data.Default
       ) where

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)

import Refined

type Level' = Refined NonNegative Float
data Level = Lin { toLin :: Level' } | DB { toLin :: Level' }

instance Num Level where
  (+) = fmap (either error id) . asFloat (+)
  (-) = fmap (either error id) . asFloat (-)
  (*) = fmap (either error id) . asFloat (*)
  abs = id
  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 = unrefine . toLin

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 :: Level' -> Float
linToDb (unrefine -> x) = 20 * (logBase 10 x)

dBToLin :: Float -> Level'
dBToLin x = either error id . refine $ 10 ** (0.05 * x)

instance Show Level where
  show (Lin (unrefine -> x)) = show x
  show (DB (linToDb -> x)) = (show $ (withPrec x :: Milli)) ++ "dB"

instance Read Level where
  readsPrec = readPrec_to_S $ parseDb <|> parseLin
    where
      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 = do
        lin <- readS_to_Prec readsPrec
        either (const mzero) (return . Lin) $ refine lin

instance Eq Level where
  (==) = (==) `on` toLin

instance Ord Level where
  compare = compare `on` toLin

instance Default Level where
  def = Lin $$(refineTH 0)



newtype Balance = Balance { unBalance :: Refined ZeroToOne Float }
  deriving (Ord, Eq)

bAsFloat :: (Float -> Float -> Float) -> Balance -> Balance -> Either String Balance
bAsFloat f (unrefine . unBalance -> x) (unrefine . unBalance -> y) = fmap Balance . refine $ f x y

bToFloat :: Balance -> Float
bToFloat = unrefine . unBalance

instance Num Balance where
  (+) = fmap (either error id) . bAsFloat (+)
  (-) = fmap (either error id) . bAsFloat (-)
  (*) = fmap (either error id) . bAsFloat (*)
  abs = id
  signum = Balance . either error id . refine . signum . bToFloat
  fromInteger = Balance . either error id . refine . fromInteger

instance Show Balance where
  show = show . bToFloat
  
instance Read Balance where
  readsPrec = readPrec_to_S $ do
    b <- readS_to_Prec readsPrec
    either (const mzero) (return . Balance) $ refine b

instance Default Balance where
  def = Balance $$(refineTH 1)
  

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

instance Adjustable Balance where
  add = (+)
  sub = (-)

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