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

module Trivmix.Types
       ( Level'
       , Level(Lin, toLin)
       , toScientific
       , asScientific
       , Balance(..)
       , bToScientific
       , bAsScientific
       , 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

import Data.Scientific
import Data.Scientific.Lift


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

instance Num Level where
  (+) = fmap (either error id) . asScientific (+)
  (-) = fmap (either error id) . asScientific (-)
  (*) = fmap (either error id) . asScientific (*)
  abs = id
  signum = Lin . either error id . refine . signum . toScientific
  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)
  where
    toLvl
      | DB _ <- x = DB
      | DB _ <- y = DB
      | otherwise = Lin

toScientific :: Level -> Scientific
toScientific = 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' -> 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)

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 Scientific }
  deriving (Ord, Eq)

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

bToScientific :: Balance -> Scientific
bToScientific = unrefine . unBalance

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

instance Show Balance where
  show = show . bToScientific
  
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