{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, FlexibleInstances #-} 

{-| A checked value is a value, potentially wrapped in a warning, i.e. a non-fatal exception.

Where the checked value looks like (Right value), the value is within limits
Where the checked value looks like (Left (warning, cause, value)), the value is out of limits

Warning is (\"warning message\", severity), and cause is also a (Left (warning, cause value)) which allows a \"linked list\" of warnings to be set up

Run your code within a 'Checked' monad to benefit from real time checking

To retrofit checking to an existing function myFunc :: MyType1 -> MyType2 -> MyType3:

(a) define a type which is a tuple of the parameters to myFunc
   
@
    type  MyFuncParams = (MyType1, MyType2)
@

(b) define the test for validity of the parameters expected by myFunc:

@
     instance Checkable MyFuncParams where
       check params = .. Checked (Right params) -- if OK
                      .. Checked (Left (pack \"Invalid params to myFunc\", 20), Nothing, params) -- if params are out of whack
@

(c) define the test for validity of the output type, or any type in your code:

@
     instance 'Checkable' MyType3 where
       check v = .. Checked (Right v) -- if OK
                 .. Checked (Left (pack \"Type MyType3 is out of range\", 20), Nothing, v) -- if the value is out of whack for this type
@
 
(d) define a wrapper function for myFunction for myFunc which accepts a parameter of type MyFuncParams:

@
     myFunc\' :: MyFuncParams -> MyType3
     myFunc\' (a, b) = myFunc a b
 \* Looking to automate this step, perhaps with TH \*
@

(e) run your function within the 'Checked' monad, using 'applyWithParamsCheck' as the function calls, and 'check' to check the output values

@
 code :: MyType1 -> MyType2 -> Checked MyType4
 code a b = do
     f <- applyWithCheckedParams myFunc\' (a, b)
     g <- check y
     h <- applyWithCheckedParams myFunc1\' g
     check h
@
-}
module Data.Checked

where

import Data.Text
import Control.Applicative
import Control.Monad

-- |A warning that the value is not within limits, with a measurable indication of severity
type Warning = (Text, Integer)

-- |A wrapper type indicating that the value is or is not within limits
data Checked a =  forall b. Checked (Either (Warning, Maybe (Checked b), a) a)

-- |Useful function
getCheckedValue :: Checked a -> a
getCheckedValue (Checked (Left (_, _, v))) = v
getCheckedValue (Checked (Right v)) = v

-- |This is implemented for types whose values will be checked
class (Checkable a) where
  check :: a -> Checked a

-- |for debugging

instance (Show a) => Show (Checked a) where
 show (Checked (Right v)) = show v
 show (Checked (Left ((t, s), Nothing, v))) = unpack t ++ show s ++ show v
 show (Checked (Left ((t, s), Just ch, v))) = unpack t ++ show s ++ show v ++ "together with: " ++ showChecked ch
      where
        showChecked :: Checked b -> String
        showChecked (Checked (Left ((t', s'), Nothing, v'))) = unpack t' ++ show s'
        showChecked (Checked (Left (w, Just ch', v'))) = (showChecked (Checked (Left (w, Nothing, v')))) ++ showChecked ch'

-- |The function is simply applied to the value within the checked wrapper
instance Functor Checked where
 fmap f (Checked (Right v)) = Checked (Right (f v))
 fmap f (Checked (Left ((t, s), mb, v))) = Checked (Left ((t, s), mb, f v))

-- |Checked values combine as you would expect, except that two Left values combine to set up a trace of warnings
instance Applicative Checked where
 pure v = Checked (Right v)
 (Checked (Right f)) <*> (Checked (Right v)) = Checked (Right (f v))
 (Checked (Right f)) <*> (Checked (Left ((t, s), mb, v))) = Checked (Left ((t, s), Just (Checked (Left ((t, s), mb, v))), f v))
 (Checked (Left ((t, s), mb, f))) <*> (Checked (Right v)) = Checked (Left ((t, s), mb, f v))
 (Checked (Left ((t, s), mb, f))) <*> (Checked (Left ((t', s'), mb', v'))) = Checked (Left ((t, s), Just (Checked (Left ((t', s'), mb', v'))), f v'))
          
-- |The monadic values also combine like the Applicative
instance Monad Checked where
 Checked (Right v) >>= k = k v
 Checked (Left (w, mb, v)) >>= k = pure id <$> Checked (Left (w, mb, v)) <*> k v
 return v = Checked (Right v) 


-- |This is needed because we need to select the correct check function for the parameters to this function
-- We do this by capturing the parameters as a single type, for which we have defined a checkable instance
 
applyWithParamsCheck :: Checkable a => (a -> b) -> a -> Checked b
applyWithParamsCheck f params = fmap f (check params)




--now some testing
-- a type whose values should normally be less than 100
data UnderOneHundred a = UnderOneHundred a deriving (Show, Eq, Ord)

--an existing function which we are going to retrofit into checked
sumTest :: UnderOneHundred Integer -> UnderOneHundred Integer -> UnderOneHundred Integer
sumTest (UnderOneHundred i) (UnderOneHundred j) = UnderOneHundred $ i + j

--make the UnderOneHundred type checkable
-- if the value is out of whack, signal with a severity rating of 50
instance (Num a, Eq a, Ord a) => Checkable (UnderOneHundred a) where
 check (UnderOneHundred i) = if (i < 100)
  then Checked (Right (UnderOneHundred i))
  else Checked (Left ((pack "Value exceeds expected limit", 50), Nothing, (UnderOneHundred i))) 

--define a type representing a tuple of parameter types into sumTest
type SumTestFuncParams =  (UnderOneHundred Integer, UnderOneHundred Integer)

-- a wrapper function for the function to be retrofitted
sumTest' :: SumTestFuncParams -> UnderOneHundred Integer
sumTest' (a, b) = sumTest a b

--then make the parameters expected by this particular function checkable
-- in this case, the first parameter should not exceed the second parameter
-- if the parameters are out of whack, signal with a severity rating of 20

instance Checkable SumTestFuncParams where
 check (j, k) = if (j < k)
                               then Checked (Right ((j, k) :: SumTestFuncParams))
                               else Checked (Left ((pack "first param exceeds the second param", 20), Nothing, (j, k) :: SumTestFuncParams))
                               

           
--monadic use of the checker 

test :: UnderOneHundred Integer -> UnderOneHundred Integer -> Checked (UnderOneHundred Integer)
test a b = do
-- call sumTest while checking the validity of the parameters
 y <- applyWithParamsCheck sumTest' (a, b)
-- check the output of sumTest'
 check y
-- or e.g. z <- check y
-- applyWithParamsCheck nextFunc' z
-- etc. etc.