DataInstanceForSecret.hs

{-# LANGUAGE DeriveDataTypeable   #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE UndecidableInstances #-}

module Main where

import Data.Char
import Data.Generics
import Data.Reflection

{-------------------------------------------------------------------------------
  Secret infrastructure
-------------------------------------------------------------------------------}

-- | Secret information
--
-- NOTE: For the sake of this demonstration, giving this a regular 'Show'
-- instance, so we can see what's going on with the SYB traverals.
data Secret a = Secret a
  deriving (Show)

data SecretContext = SafelyHideSecrets | RiskyShowSecrets

{-------------------------------------------------------------------------------
  Example custom Data instance
-------------------------------------------------------------------------------}

data T = T String (Secret String)
  deriving (Show)

deriving instance Given SecretContext => Data T

secretType   :: DataType
secretConstr :: Constr

secretType   = mkDataType "Secret" [secretConstr]
secretConstr = mkConstr secretType "Secret" [] Prefix

instance (Given SecretContext, Data a) => Data (Secret a) where
  gfoldl  k z s@(Secret a) = case given of
                               SafelyHideSecrets -> z s
                               RiskyShowSecrets  -> z Secret `k` a
  gunfold k z _            = k (z Secret)
  toConstr (Secret _)      = secretConstr
  dataTypeOf _             = secretType

{-------------------------------------------------------------------------------
  Demonstration
-------------------------------------------------------------------------------}

collect :: (Data a, Typeable b) => a -> [b]
collect x = mkQ (concat $ gmapQ collect x) (:[]) x

collectStrings :: Data a => a -> [String]
collectStrings = collect

apply :: (Data a, Data b) => (a -> a) -> (b -> b)
apply f x =
    case cast f of
      Just f' -> f' x
      Nothing -> gmapT (apply f) x

strToUpper :: String -> String
strToUpper = map toUpper

main :: IO ()
main = do
    -- > ["not secret"]
    give SafelyHideSecrets $
      print $ collectStrings (T "not secret" (Secret "this is secret"))
    -- > ["not secret","this is secret"]
    give RiskyShowSecrets $
      print $ collectStrings (T "not secret" (Secret "this is secret"))
    -- > T "NOT SECRET" (Secret "this is secret")
    -- NOTE: If given 'SafelyHideSecrets', the function is not applied!
    give SafelyHideSecrets $
      print $ apply strToUpper (T "not secret" (Secret "this is secret"))
    -- > T "NOT SECRET" (Secret "THIS IS SECRET")
    give RiskyShowSecrets $
      print $ apply strToUpper (T "not secret" (Secret "this is secret"))