Boilerplate revisited

[Markus.Schnell at infineon.com]

Perhaps some remember the question I posted about 
avoiding boilerplate some time ago: 
(http://haskell.org/pipermail/haskell/2003-August/012479.html)

After some experimentation I employed Hal's DynamicMap as well
as the Generics library. This worked fine for a while, but after
I started using my program on bigger problems it soon turned out
that the program spent more than 40% (!) of its memory on the
lookupDM operation and most of its time on stypeOf.

This was not acceptable and so I switched back to my original 
solution (albeit somewhat easier implemented), which is...
...using lots of boilerplate. The memory usage drops to 
roughly 2% for lookupDM.

For those interested, the approach is described below.
Instead of coding the boilerplate by hand, I wrote a
function for automatic generation, making it more robust 
and extensible.
There's also room for improvement, but I needed a quick,
working solution, not a perfect one.

The alert reader may have noticed that I didn't mention
Generics again. First I was using a map function like this

> segmap f s = everywhere (mkT f) s

planning to explore some of the visiting strategies.

But this resulted in spending a lot of time in the segmap function, 
while using a self-written map on the structure was much faster. 
I didn't keep records, though.
Perhaps the boilerplate people (Ralf Lämmel, Simon PJ) have already
looked at performance issues?


If you stayed with me, thank you for your time.

Markus





 === Approach Description ===

Four modules are of interest:
Defs        -  attribute definitions
Attribute   -  setter/getter/helper functions
MyTypeable  -  boilerplate
DynamicMap  -  an interface to finite map


Here are the prototypical implementations:


module Defs
where

data Gender    = Masc | Fem | Neutr    deriving (Eq, Show)
data Accented  = Accented  deriving (Eq, Show)
data Focused   = Focused   deriving (Eq, Show)

...






module Attribute
  ( Gender
  , gender,  accented, focused
  , ggender, isAccented, isFocused ) where

import Defs
import MyTypeable
import DynamicMap
...

-- Segment is the manipulated structure, containing the attributes
sattr :: (MyTypeable a) => a -> Segment -> Segment
sattr a s =  s { attrs = sattrW a (attrs s) }

sattrW :: (MyTypeable a) => a -> Attrs -> Attrs
sattrW x  = (flip addToDM) x 

gattr :: (MyTypeable a) => Segment -> Maybe a
gattr = gattrW . attrs 

gattrW :: (MyTypeable a) => Attrs -> Maybe a                   
gattrW = lookupDM

type GetAttr a = Segment -> Maybe a
type SetAttr a = a -> Segment -> Segment

ggender    = gattr :: GetAttr Gender
gender     = sattr :: SetAttr Gender

accented   = sattr Accented
focused    = sattr Focused

isAccented, isFocused :: Segment -> Bool
isAccented = isJust . (gattr::GetAttr Accented)
isFocused  = isJust . (gattr::GetAttr Focused)

...






module DynamicMap ( ... ) where -- shamelessly building on Hal Daumé's
module

import Data.FiniteMap
import MyTypeable

newtype DynamicMap = DM { unDM :: FiniteMap TypeRep TypeWrapper }

-- ignoring some obvious stuff (emptyDM, ...)


addToDM :: (MyTypeable a) => DynamicMap -> a -> DynamicMap
addToDM (DM dm) a = DM $ addToFM dm (typeOf a) (toDyn a)

lookupDM :: MyTypeable a => DynamicMap -> Maybe a
lookupDM (DM dm) :: Maybe a =
    case lookupFM dm (typeOf (undefined :: a)) of
      Nothing -> Nothing
      Just x  -> fromDyn x








module MyTypeable where

import Defs

type TypeRep = Int

class MyTypeable a where
  typeOf  :: a -> TypeRep
  toDyn   :: a -> TypeWrapper
  fromDyn :: TypeWrapper -> Maybe a



-- === Start Of Automatic Generated Code
=======================================
-- put in here automatic generated code
-- === End Of Automatic Generated Code
========================================

-- The following generates the wrappers for the types. This is a very
-- straightforward implementation, no need for optimization encountered.
-- Call gentmp and put it in the "automatic generated code" section.

gentmp = writeFile "tmp.txt" (generateTypeWrappers typesToWrap)

typesToWrap = [ "Gender", "Accented", "Focused" ]

generateTypeWrappers = generateTypeWrappers' "" "" 0 

generateTypeWrappers'
  :: String   -- TypeWrapper accu
  -> String   -- Instances accu
  -> Int      -- current instance
  -> [String] -- list of types
  -> String   -- code string

generateTypeWrappers' tpa ia n [] 
  = "data TypeWrapper = StandInForEasierAutomaticGeneration\n"
    ++ tpa ++ "\n\n" ++ ia

generateTypeWrappers' tpa ia n (x:xs)
  = generateTypeWrappers' (tpa ++ wrap n x) (ia ++ inst n x) (n + 1) xs
  

-- make one wrap
wrap n x = "  | T" ++ show n ++ " " ++ x ++ "\n"


-- make one instance
inst n x = "instance MyTypeable " ++ x ++ " where\n"
           ++ "  typeOf _       = " ++ show n ++ "\n"
           ++ "  toDyn          = T" ++ show n ++ "\n"
           ++ "  fromDyn (T" ++ show n ++ " x) = Just x\n"
           ++ "  fromDyn _      = Nothing\n\n\n"