hpaste

import qualified Data.Map as Map


data Color = Red | Yellow | Green | Blue | White | Black deriving (Show)
data Property = ColorProp Color | SizeProp Integer deriving (Show)
type Properties = Map.Map String Property

class HasProp o where
  getProps :: o -> Properties
  setProps :: o -> Properties -> o
  getProp :: (Monad m) => String -> o -> m Property
  getProp name obj = Map.lookup name (getProps obj)
  getPropWithDefault :: String -> Property -> o -> Property
  getPropWithDefault name def obj = Map.findWithDefault def name (getProps obj)
  setProp :: String -> o -> Property -> o
  setProp name obj prop = setProps obj (Map.insert name prop (getProps obj))


class HasProp o => Colored o where
  color :: o -> Color
  color obj = col where ColorProp col = getPropWithDefault "color" (ColorProp Black) obj
  setColor :: o -> Color -> o
  setColor obj col = setProp "color" obj (ColorProp col)

class HasProp o => Sized o where
  size :: o -> Integer
  size obj = s where SizeProp s = getPropWithDefault "size" (SizeProp 10) obj
  setSize :: o -> Integer -> o
  setSize obj s = setProp "size" obj (SizeProp s)


data Cube = Cube { cube_props :: Properties } deriving (Show)
data Car  = Car  { car_props  :: Properties } deriving (Show)

default_cube = Cube { cube_props = Map.empty }
default_car  = Car  { car_props  = Map.empty }

instance HasProp Cube
  where
    getProps            =  cube_props
    setProps obj props  =  obj { cube_props = props }
instance HasProp Car
  where
    getProps            =  car_props
    setProps obj props  =  obj { car_props = props }

instance Colored Cube
instance Colored Car
instance Sized   Car

main = putStrLn (show (color (default_car `setColor` Red)))

import qualified Data.Map as Map


data Color         = Red | Yellow | Green | Blue | White | Black deriving (Show)
data Property      = ColorProp | SizeProp deriving (Eq, Ord, Show)
data PropertyValue = ColorValue Color | SizeValue Integer deriving (Show)
type Properties    = Map.Map Property PropertyValue

class HasProp o where
  getProps :: o -> Properties
  setProps :: o -> Properties -> o
  getProp :: (Monad m) => Property -> o -> m PropertyValue
  getProp prop obj = Map.lookup prop (getProps obj)
  getPropWithDefault :: Property -> PropertyValue -> o -> PropertyValue
  getPropWithDefault prop def obj = Map.findWithDefault def prop (getProps obj)
  setProp :: Property -> o -> PropertyValue -> o
  setProp prop obj value = setProps obj (Map.insert prop value (getProps obj))


class HasProp o => Colored o where
  color :: o -> Color
  color obj = col where ColorValue col = getPropWithDefault ColorProp (ColorValue Black) obj
  setColor :: o -> Color -> o
  setColor obj col = setProp ColorProp obj (ColorValue col)

class HasProp o => Sized o where
  size :: o -> Integer
  size obj = s where SizeValue s = getPropWithDefault SizeProp (SizeValue 10) obj
  setSize :: o -> Integer -> o
  setSize obj s = setProp SizeProp obj (SizeValue s)


data Cube = Cube { cube_props :: Properties } deriving (Show)
data Car  = Car  { car_props  :: Properties } deriving (Show)

default_cube = Cube { cube_props = Map.empty }
default_car  = Car  { car_props  = Map.empty }

instance HasProp Cube
  where
    getProps            =  cube_props
    setProps obj props  =  obj { cube_props = props }
instance HasProp Car
  where
    getProps            =  car_props
    setProps obj props  =  obj { car_props = props }

instance Colored Cube
instance Colored Car
instance Sized   Car

main = putStrLn (show (color (default_car `setColor` Red)))

{-# LANGUAGE FlexibleInstances, FlexibleContexts, Rank2Types, DeriveDataTypeable, UndecidableInstances  #-}

module Records where

import Data.Generics.Basics
import Data.Generics.Aliases
import Data.Generics.Schemes
import Control.Monad
import Data.Maybe

greplace :: forall a b. (Data a, Typeable b) => a -> b -> Maybe a
greplace x y = once (return Nothing `extM` (const (return y))) x

once:: MonadPlus m => GenericM m -> GenericM m
once f x = f x `mplus` gmapMo (once f) x

data Color         = Red | Yellow | Green | Blue | White | Black deriving (Show, Data, Typeable)
data Size = Size Int deriving (Show, Data, Typeable)

data Car = Car Color Size deriving (Data, Typeable, Show)
data Cube = Cube Color deriving (Data, Typeable, Show)

class Data a => HasColor a where
    getColor :: a -> Color
    getColor = fromJust . gfindtype
    setColor :: a -> Color -> a
    setColor = (fromJust .) . greplace

class Data a => HasSize a where
    getSize :: a -> Size
    getSize = fromJust . gfindtype
    setSize :: a -> Size -> a
    setSize = (fromJust .) . greplace

instance HasColor Car
instance HasColor Cube
instance HasSize Car

{-
*Records> getColor (Car Red (Size 12))
Red

*Records> setColor (Car Red (Size 12)) Blue
Car Blue (Size 12)

*Records> getColor (Cube Green)
Green

*Records> setSize (Car Blue (Size 23)) (Size 192)
Car Blue (Size 192)
-}

--or hiding the size constructor from the HasSize method

data Size = Size Int deriving (Show, Data, Typeable)

unSize Size a = a

class Data a => HasSize a where
    getSize :: a -> Int
    getSize = unSize . fromJust . gfindtype
    setSize :: a -> Int -> a
    setSize = (fromJust .) . (. Size) . greplace

Powered by HAppS. Copyright (c) 2007 glguy @ #haskell. Source via darcs.