gdritter repos fulcrum / master Data / Analysis / Fulcrum / Abstract.hs
master

Tree @master (Download .tar.gz)

Abstract.hs @masterraw · history · blame

module Data.Analysis.Fulcrum.Abstract
  ( Abstract
  , makeAbs
  , absShow
  , absShowS
  ) where

import Data.Dynamic
import Data.Monoid
import Data.Typeable (Typeable)

-- | An abstract value is a wrapper over Dynamic that supports
--   heterogeneous comparison, equality, and retains access to
--   the underlying 'show' implementation. This allows us to use
--   selectors over possibly heterogeneous values without
--   various kinds of type-wrangling.
data Abstract = Abstract
  { absVal :: Dynamic
  , absEq  :: Abstract -> Bool
  , absCmp :: Abstract -> Ordering
  , absStr :: String
  }

-- | Print out a comma-separated list of the values contained
--   in a list of 'Abstract' values.
absShowS :: [Abstract] -> String
absShowS [] = ""
absShowS [x] = absShow x
absShowS (x:xs) = absShow x ++ "," ++ absShowS xs

-- | Get the string representation of the interior value of an
--   'Abstract'. (Note that the 'Show' instance for 'Abstract'
--   will also print out the fact that it's an 'Abstract' value,
--   whereas this will omit it.)
absShow :: Abstract -> String
absShow = absStr

over :: Typeable a => (a -> b) -> b -> Dynamic -> b
over op def dyn
  | Just x <- fromDynamic dyn = op x
  | otherwise                 = def

-- | Create an 'Abstract' value. This does mean that relevant
--   values in your rows must have a 'Typeable' constraint.
makeAbs :: (Typeable t, Ord t, Show t) => t -> Abstract
makeAbs x = Abstract
  { absVal = toDyn x
  , absEq  = doEq . absVal
  , absCmp = doCmp . absVal
  , absStr = show x
  } where doEq = over (== x) False
          doCmp y = over (compare x) (cmpTyp y) y
          cmpTyp y = dynTypeRep (toDyn x) `compare` dynTypeRep y

instance Eq Abstract where a == b = a `absEq` b
instance Show Abstract where show a = "makeAbs (" ++ absStr a ++ ")"
instance Ord Abstract where a `compare` b = a `absCmp` b