[remove a bunch of stuff from DerivingDrift that is not relevant.
John Meacham <john@repetae.net>**20080218074626] hunk ./DerivingDrift/DataP.hs 7
-module DerivingDrift.DataP (Statement(..),Data(..),Type(..),Body(..),
-		Name,Var,Class,Constructor)
-where
+module DerivingDrift.DataP where
hunk ./DerivingDrift/DataP.hs 13
-data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
-data Data = D {	name :: Name,		-- type name
-			constraints :: [(Class,Var)],
-			vars :: [Var],		-- Parameters
-			body :: [Body],
-			derives :: [Class],		-- derived classes
-			statement :: Statement}
-		deriving (Eq,Show)
-data Body = Body { constructor :: Constructor,
-		    labels :: [Name],
-		    types :: [HsBangType]} deriving (Eq,Show)
+data Statement = DataStmt | NewTypeStmt 
+    deriving (Eq,Show)
+
+data Data = D {
+    name :: Name,		-- type name
+    constraints :: [(Class,Var)],
+    vars :: [Var],		-- Parameters
+    body :: [Body],
+    derives :: [Class],		-- derived classes
+    statement :: Statement
+    } deriving (Eq,Show)
+
+data Body = Body {
+    constructor :: Constructor,
+    labels :: [Name],
+    types :: [HsBangType]
+    } deriving (Eq,Show)
+
hunk ./DerivingDrift/DataP.hs 35
-----------------------------------------------------------------------------
-
----------------------------------------------------------------------------
-data Type	= Arrow Type Type -- fn
-		| LApply Type [Type] -- proper application
-		| Var String	  -- variable
-		| Con String      -- constructor
-		| Tuple [Type]	  -- tuple
-		| List Type	  -- list
-			deriving (Eq,Show)
-
hunk ./DerivingDrift/RuleFunctorM.hs 1
--- stub module to add your own rules.
-module RuleFunctorM (rules) where
-
-import List
-import DerivingDrift.RuleUtils
-
-rules = [
-    ("FunctorM", userRuleFunctorM, "Generics", "derive reasonable fmapM implementation", Nothing),
-    ("RMapM", userRuleRMapM, "Generics", "derive reasonable rmapM implementation", Nothing)
-    ]
-
-{- datatype that rules manipulate :-
-
-
-data Data = D {	name :: Name,			 -- type's name
-			constraints :: [(Class,Var)],
-			vars :: [Var],		 -- Parameters
-			body :: [Body],
-			derives :: [Class],	 -- derived classes
-			statement :: Statement}  -- type of statement
-	   | Directive				 --|
-	   | TypeName Name			 --| used by derive (ignore)
-		deriving (Eq,Show)
-
-data Body = Body { constructor :: Constructor,
-		    labels :: [Name], -- [] for a non-record datatype.
-		    types :: [Type]} deriving (Eq,Show)
-
-data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
-
-type Name = String
-type Var = String
-type Class = String
-type Constructor = String
-
-type Rule = (Tag, Data->Doc)
-
--}
-
-{-
-
--- useful helper things
-namesupply   = [text [x,y] | x <- ['a' .. 'z'],
-                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
-mknss []     _  = []
-mknss (c:cs) ns =
-  let (thisns,rest) = splitAt (length (types c)) ns
-  in thisns: mknss cs rest
-
-mkpattern :: Constructor -> [a] -> [Doc] -> Doc
-mkpattern c l ns =
-  if null l then text c
-  else parens (hsep (text c : take (length l) ns))
-
-instanceheader cls dat =
-  let fv     = vars dat
-      tycon  = name dat
-      ctx    = map (\v-> text cls <+> text v)
-      parenSpace = parens . hcat . sepWith space
-  in
-  hsep [ text "instance"
-       , opt fv (\v -> parenList (ctx v) <+> text "=>")
-       , text cls
-       , opt1 (texts (tycon: fv)) parenSpace id
-       , text "where"
-       ]
-
--}
-
-
-
--- begin here for Binary derivation
-
-
-userRuleFunctorM D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive FunctorM without type variables"
-userRuleFunctorM D{name = name, vars = vars, body=body } = ins where
-    (tt:rt') = reverse vars
-    rt = reverse rt'
-    fn = if null rt then text name else parens (text name <+> hsep (map text rt))
-    ins = text "instance" <+> text "FunctorM" <+> fn <+> text "where" $$ block fs
-    fs = map f' $ body
-    f' Body{constructor=constructor, types=types} = text "fmapM" <+> text "f" <+> pattern constructor types <+> equals <+> text "do" <+> hcat (map g (zip types vnt)) <+> text "return $" <+> text constructor <+> hsep vnt where
-        vnt = varNames types
-        g (t,n) | not (has t) = empty
-        g (Var t,n) | t == tt = n <+> lArrow <+> text "f" <+> n <> semicolon
-        g (List (Var t),n) | t == tt = n <+> lArrow <+> text "mapM" <+> f <+> n <> semicolon
-        g (List t,n)  = n <+> lArrow <+> text "mapM" <+> lf t <+> n <> semicolon  where
-            lf t = parens $ text "\\x ->" <+> text "do" <+> g (t,x) <+> text "return" <+> x
-        g (LApply t [],n) = g (t,n)
-        g (LApply t ts,n) | last ts == Var tt = n <+> lArrow <+> text "fmapM" <+> f <+> n <> semicolon
-        g (Tuple ts,n) = n <+> lArrow <+> (parens $ text "do" <+> tuple (varNames ts) <+> lArrow <+> text "return" <+> n <> semicolon  <+> hcat (map g (zip ts (varNames ts))) <> text "return" <+> tuple (varNames ts)) <> semicolon
-        g _ = empty
-    has (Var t) | t == tt = True
-    has (List t) = has t
-    has (Arrow a b) = has a || has b
-    has (LApply t ts) = any has (t:ts)
-    has (Tuple ts) = any has (ts)
-    has _ = False
-
-userRuleRMapM D{name = name, vars = vars, body=body } = ins where
-    --(tt:rt') = reverse vars
-    tt = if null vars then Con name else LApply (Con name) (map Var vars)
-    rt = vars
-    fn = if null rt then text name else parens (text name <+> hsep (map text rt))
-    ins = text "instance" <+> text "RMapM" <+> fn <+> text "where" $$ block fs
-    fs = map f' $ body
-    f' Body{constructor=constructor, types=types} = text "rmapM" <+> text "f" <+> pattern constructor types <+> equals <+> text "do" <+> hcat (map g (zip types vnt)) <+> text "return $" <+> text constructor <+> hsep vnt where
-        vnt = varNames types
-        g (t,n) | not (has t) = empty
-        g ( t,n) | t == tt = n <+> lArrow <+> text "f" <+> n <> semicolon
-        g (List (t),n) | t == tt = n <+> lArrow <+> text "mapM" <+> f <+> n <> semicolon
-        g (List t,n)  = n <+> lArrow <+> text "mapM" <+> lf t <+> n <> semicolon  where
-            lf t = parens $ text "\\x ->" <+> text "do" <+> g (t,x) <+> text "return" <+> x
-        g (LApply t [],n) = g (t,n)
-        g (LApply t ts,n) | last ts ==  tt = n <+> lArrow <+> text "fmapM" <+> f <+> n <> semicolon
-        g (Tuple ts,n) = n <+> lArrow <+> (parens $ text "do" <+> tuple (varNames ts) <+> lArrow <+> text "return" <+> n <> semicolon  <+> hcat (map g (zip ts (varNames ts))) <> text "return" <+> tuple (varNames ts)) <> semicolon
-        g _ = empty
-    has t | t == tt = True
-    has (List t) = has t
-    has (Arrow a b) = has a || has b
-    has (LApply t ts) = any has (t:ts)
-    has (Tuple ts) = any has (ts)
-    has _ = False
-
rmfile ./DerivingDrift/RuleFunctorM.hs
hunk ./DerivingDrift/RuleMonoid.hs 1
--- stub module to add your own rules.
-module RuleMonoid (rules) where
-
-import List
-import DerivingDrift.RuleUtils
-
-rules = [
-    ("Monoid", userRuleMonoid, "Generics", "derive reasonable Data.Monoid implementation", Nothing)
-    ]
-
-{- datatype that rules manipulate :-
-
-
-data Data = D {	name :: Name,			 -- type's name
-			constraints :: [(Class,Var)],
-			vars :: [Var],		 -- Parameters
-			body :: [Body],
-			derives :: [Class],	 -- derived classes
-			statement :: Statement}  -- type of statement
-	   | Directive				 --|
-	   | TypeName Name			 --| used by derive (ignore)
-		deriving (Eq,Show)
-
-data Body = Body { constructor :: Constructor,
-		    labels :: [Name], -- [] for a non-record datatype.
-		    types :: [Type]} deriving (Eq,Show)
-
-data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
-
-type Name = String
-type Var = String
-type Class = String
-type Constructor = String
-
-type Rule = (Tag, Data->Doc)
-
--}
-
-
--- useful helper things
-
-mkpattern :: Constructor -> [Doc] -> Doc
-mkpattern c ns =
-  if null ns then text c
-  else parens (hsep (text c :  ns))
-
-instanceheader cls dat =
-  let fv     = vars dat
-      tycon  = name dat
-      ctx    = map (\v-> text cls <+> text v)
-      parenSpace = parens . hcat . sepWith space
-  in
-  hsep [ text "instance"
-       , opt fv (\v -> parenList (ctx v) <+> text "=>")
-       , text cls
-       , opt1 (texts (tycon: fv)) parenSpace id
-       , text "where"
-       ]
-
-
-
-
--- begin here for Binary derivation
-
-
-userRuleMonoid dat@D{name = name, vars = vars, body=[body] } = ins where
-    ins = instanceheader "Monoid" dat $$
-        block [me, ma]
-    me, ma :: Doc
-    me = text "mempty" <+> equals <+> text (constructor body) <+> hsep (replicate lt (text "mempty"))
-    ma = text "mappend" <+> mkpattern c (varNames ty) <+> mkpattern c (varNames' ty) <+> equals <+> text c <+> hcat (zipWith f (varNames ty) (varNames' ty))
-    f a b = parens $ text "mappend"  <+> a <+> b
-    c = constructor body
-    ty = types body
-    lt = length (types body)
-userRuleMonoid D{name = name } = text "--" <+> text name <> text ": Cannot derive Monoid from type"
-
-
rmfile ./DerivingDrift/RuleMonoid.hs
hunk ./DerivingDrift/RuleUtility.hs 1
-module DerivingDrift.RuleUtility(rules) where
-import DerivingDrift.RuleUtils
-import List
-import GenUtil
-
-rules :: [RuleDef]
-rules = [("Query",queryGen, "Utility", "provide a QueryFoo class with 'is', 'has', 'from', and 'get' routines", Nothing) ]
-
-
-queryGen :: Data -> Doc
-queryGen d@D{name = name} = cls $$ text "" $$ ins where
-    cls = text "class" <+> text className <+> typeName <+> cargs <+> text "where" $$ block fs
-    ot a b = a <+> text "::" <+> b
-    cargs = if null $ vars d then empty else dargs <+> text "|" <+> typeName <+> text "->" <+> dargs
-    dargs =  hsep (map text $ vars d)
-    className = "Query" ++ name
-    typeName = text "_x"
-    fs = (map is (body d) )
-    is Body{constructor = constructor, types = types} = fn $$ dfn $$ ffn where
-        fnName = text $ "is" ++ constructor
-        fromName = "from" ++ constructor
-        fn = ot fnName $  typeName <+> rArrow <+> text "Bool"
-        dfn = fnName <+> x <+> text "=" <+> text "isJust" <+> parens (text fromName <+> x)
-        ffn = ot (text fromName) $ text "Monad _m =>" <+> typeName <+> rArrow <+> text "_m" <+> tuple (map prettyType types)
-
-    ins = text "instance" <+> text className <+> parens (text name <+> dargs) <+> dargs <+> text "where" $$ block fromInsts
-    fromInsts = map fi (body d)
-    fi Body{constructor = constructor, types = types} = fn $$ dfn where
-        fromName = "from" ++ constructor
-        fn = text fromName <+> pattern constructor types <+> text "=" <+> text "return" <+> tuple (varNames types)
-        dfn = text fromName <+> blank <+> equals <+> text "fail" <+> tshow fromName
-
rmfile ./DerivingDrift/RuleUtility.hs
hunk ./DerivingDrift/RuleUtils.hs 5
---import DerivingDrift.Pretty
hunk ./DerivingDrift/RuleUtils.hs 6
-import DerivingDrift.DataP (Statement(..),Data(..),Type(..),Name,Var,Class,
-		Body(..),Constructor)
+import DerivingDrift.DataP
hunk ./DerivingDrift/RuleUtils.hs 25
-prettyType :: Type -> Doc
---prettyType (Apply t1 t2) = parens (prettyType t1 <+> prettyType t2)
-prettyType (Arrow x y) = parens (prettyType x <+> text "->" <+> prettyType y)
-prettyType (List x) = brackets (prettyType x)
-prettyType (Tuple xs) = tuple (map prettyType xs)
-prettyType (Var s) = text s
-prettyType (Con s) = text s
-prettyType (LApply t ts) = prettyType t <+> hsep (map prettyType ts)
hunk ./DerivingDrift/UserRuleBinary.hs 1
--- stub module to add your own rules.
-module UserRuleBinary (userRulesBinary) where
-
-import List (nub,intersperse)
-import DerivingDrift.RuleUtils -- useful to have a look at this too
-
-userRulesBinary = [
-    ("Binary", userRuleBinary, "Binary", "efficient binary encoding of terms", Nothing)
-    ]
-
-{- datatype that rules manipulate :-
-
-
-data Data = D {	name :: Name,			 -- type's name
-			constraints :: [(Class,Var)],
-			vars :: [Var],		 -- Parameters
-			body :: [Body],
-			derives :: [Class],	 -- derived classes
-			statement :: Statement}  -- type of statement
-	   | Directive				 --|
-	   | TypeName Name			 --| used by derive (ignore)
-		deriving (Eq,Show)
-
-data Body = Body { constructor :: Constructor,
-		    labels :: [Name], -- [] for a non-record datatype.
-		    types :: [Type]} deriving (Eq,Show)
-
-data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
-
-type Name = String
-type Var = String
-type Class = String
-type Constructor = String
-
-type Rule = (Tag, Data->Doc)
-
--}
-
-
--- useful helper things
-namesupply   = [text [x,y] | x <- ['a' .. 'z'],
-                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
-mknss []     _  = []
-mknss (c:cs) ns =
-  let (thisns,rest) = splitAt (length (types c)) ns
-  in thisns: mknss cs rest
-
-mkpattern :: Constructor -> [a] -> [Doc] -> Doc
-mkpattern c l ns =
-  if null l then text c
-  else parens (hsep (text c : take (length l) ns))
-
-instanceheader cls dat =
-  let fv     = vars dat
-      tycon  = name dat
-      ctx    = map (\v-> text cls <+> text v)
-      parenSpace = parens . hcat . sepWith space
-  in
-  hsep [ text "instance"
-       , opt fv (\v -> parenList (ctx v) <+> text "=>")
-       , text cls
-       , opt1 (texts (tycon: fv)) parenSpace id
-       , text "where"
-       ]
-
-
-
-
--- begin here for Binary derivation
-
-
-userRuleBinary dat =
-  let cs  = body dat
-      cvs = mknss cs namesupply
-      k   = (ceiling . logBase 2 . realToFrac . length) cs
-  in
-  instanceheader "Binary" dat $$
-  block (  zipWith3 (putfn k) [0..] cvs cs
-        ++ getfn k [0..] cvs cs
-        :  getFfn k [0..] cvs cs
-        :  zipWith (sizefn k) cvs cs
-        )
-
-putfn k n cv c =
-  text "put bh" <+> ppCons cv c <+> text "= do" $$
-  nest 8 (
-    text "pos <- putBits bh" <+> text (show k) <+> text (show n) $$
-    vcat (map (text "put bh" <+>) cv) $$
-    text "return pos"
-  )
-
-ppCons cv c = mkpattern (constructor c) (types c) cv
-
-getfn k ns cvs cs =
-  text "get bh = do" $$
-  nest 8 (
-    text "h <- getBits bh" <+> text (show k) $$
-    text "case h of" $$
-    nest 2 ( vcat $
-      zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$
-                          nest 6 (
-                            vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$
-                            text "return" <+> ppCons vs c
-                          ))
-               ns cvs cs
-    )
-  )
-
-getFfn k ns cvs cs =
-  text "getF bh p =" <+>
-  nest 8 (
-    text "let (h,p1) = getBitsF bh 1 p in" $$
-    text "case h of" $$
-    nest 2 ( vcat $
-      zipWith3 (\n vs c-> text (show n) <+> text "->" <+>
-                          parens (cons c <> text ",p1") <+>
-                          hsep (map (\_-> text "<< getF bh") vs))
-               ns cvs cs
-    )
-  )
-  where cons =  text . constructor
-
-sizefn k [] c =
-  text "sizeOf" <+> ppCons [] c <+> text "=" <+> text (show k)
-sizefn k cv c =
-  text "sizeOf" <+> ppCons cv c <+> text "=" <+> text (show k) <+> text "+" <+>
-  hsep (intersperse (text "+") (map (text "sizeOf" <+>) cv))
-
-
--- end of binary derivation
-
rmfile ./DerivingDrift/UserRuleBinary.hs
hunk ./DerivingDrift/UserRuleGhcBinary.hs 1
--- stub module to add your own rules.
-module UserRuleGhcBinary (userRulesGhcBinary) where
-
-import List (nub,intersperse)
-import DerivingDrift.RuleUtils -- useful to have a look at this too
-
-userRulesGhcBinary = [
-    ("GhcBinary", userRuleGhcBinary, "Binary", "byte sized binary encoding of terms", Nothing)
-    ]
-
-{- datatype that rules manipulate :-
-
-
-data Data = D {	name :: Name,			 -- type's name
-			constraints :: [(Class,Var)],
-			vars :: [Var],		 -- Parameters
-			body :: [Body],
-			derives :: [Class],	 -- derived classes
-			statement :: Statement}  -- type of statement
-	   | Directive				 --|
-	   | TypeName Name			 --| used by derive (ignore)
-		deriving (Eq,Show)
-
-data Body = Body { constructor :: Constructor,
-		    labels :: [Name], -- [] for a non-record datatype.
-		    types :: [Type]} deriving (Eq,Show)
-
-data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
-
-type Name = String
-type Var = String
-type Class = String
-type Constructor = String
-
-type Rule = (Tag, Data->Doc)
-
--}
-
-
--- useful helper things
-namesupply   = [text [x,y] | x <- ['a' .. 'z'],
-                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
-mknss []     _  = []
-mknss (c:cs) ns =
-  let (thisns,rest) = splitAt (length (types c)) ns
-  in thisns: mknss cs rest
-
-mkpattern :: Constructor -> [a] -> [Doc] -> Doc
-mkpattern c l ns =
-  if null l then text c
-  else parens (hsep (text c : take (length l) ns))
-
-instanceheader cls dat =
-  let fv     = vars dat
-      tycon  = name dat
-      ctx    = map (\v-> text cls <+> text v)
-      parenSpace = parens . hcat . sepWith space
-  in
-  hsep [ text "instance"
-       , opt fv (\v -> parenList (ctx v) <+> text "=>")
-       , text cls
-       , opt1 (texts (tycon: fv)) parenSpace id
-       , text "where"
-       ]
-
-
-
-
--- begin here for Binary derivation
-
-
-userRuleGhcBinary dat =
-  let cs  = body dat
-      cvs = mknss cs namesupply
-      --k   = (ceiling . logBase 256 . realToFrac . length) cs
-      k = length cs
-  in
-  instanceheader "Binary" dat $$
-  block (  zipWith3 (putfn k) [0..] cvs cs
-        ++ [getfn k [0..] cvs cs]
-        )
-
-putfn 1 _ [] c =
-    text "put_ _" <+> ppCons [] c <+> text "= return ()"
-putfn 1 _ cv c =
-  text "put_ bh" <+> ppCons cv c <+> text "= do" $$
-  nest 8 (
-    vcat (map (text "put_ bh" <+>) cv)
-  )
-putfn _ n cv c =
-  text "put_ bh" <+> ppCons cv c <+> text "= do" $$
-  nest 8 (
-    text "putByte bh" <+> text (show n) $$
-    vcat (map (text "put_ bh" <+>) cv) -- $$
-    --text "return pos"
-  )
-
-ppCons cv c = mkpattern (constructor c) (types c) cv
-
-getfn _ _ [[]] [c] =
-    text "return" <+> ppCons [] c
-getfn _ _ [vs] [c] =
-  text "get bh = do" $$
-    vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$
-    text "return" <+> ppCons vs c
-getfn _ ns cvs cs =
-  text "get bh = do" $$
-  nest 8 (
-    text "h <- getByte bh"  $$
-    text "case h of" $$
-    nest 2 ( vcat $
-      zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$
-                          nest 6 (
-                            vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$
-                            text "return" <+> ppCons vs c
-                          ))
-               ns cvs cs
-    )
-  )
-
-
-
--- end of binary derivation
-
rmfile ./DerivingDrift/UserRuleGhcBinary.hs
hunk ./DerivingDrift/UserRuleXml.hs 1
--- stub module to add your own rules.
-module UserRuleXml (userRulesXml) where
-
-import List (nub,sortBy)
-import DerivingDrift.RuleUtils -- useful to have a look at this too
-
-userRulesXml :: [RuleDef]
-userRulesXml = [("Haskell2Xml", userRuleXml, "Representation", "encode terms as XML", Nothing)]
-
-{- datatype that rules manipulate :-
-
-
-data Data = D {	name :: Name,			 -- type's name
-			constraints :: [(Class,Var)],
-			vars :: [Var],		 -- Parameters
-			body :: [Body],
-			derives :: [Class],	 -- derived classes
-			statement :: Statement}  -- type of statement
-	   | Directive				 --|
-	   | TypeName Name			 --| used by derive (ignore)
-		deriving (Eq,Show)
-
-data Body = Body { constructor :: Constructor,
-		    labels :: [Name], -- [] for a non-record datatype.
-		    types :: [Type]} deriving (Eq,Show)
-
-data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
-
-type Name = String
-type Var = String
-type Class = String
-type Constructor = String
-
-type Rule = (Tag, Data->Doc)
-
--}
-
-userRuleXml dat =
-  let cs  = body dat
-      cvs = mknss cs namesupply
-  in
-  instanceheader "Haskell2Xml" dat $$
-  block (toHTfn cs cvs dat:
-         ( text "fromContents (CElem (Elem constr [] cs):etc)" $$
-           vcat (preorder cs (zipWith3 readsfn [0..] cvs cs))):
-         zipWith3 showsfn [0..] cvs cs)
-
-toHTfn cs cvs dat =
-  let typ  = name dat
-      fvs  = vars dat
-      pats = concat (zipWith mkpat cvs cs)
-  in
-  text "toHType v =" $$
-  nest 4 (
-    text "Defined" <+>
-    fsep [ text "\"" <> text typ <> text "\""
-         , bracketList (map text fvs)
-         , bracketList (zipWith toConstr cvs cs)
-         ]
-    ) $$
-  if null pats then empty
-  else nest 2 (text "where") $$
-       nest 4 (vcat (map (<+> text "= v") pats)) $$
-       nest 4 (vcat (map (simplest typ (zip cvs cs)) fvs))
-
-namesupply   = [text [x,y] | x <- ['a' .. 'z'],
-                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
-
-mknss []     _  = []
-mknss (c:cs) ns =
-  let (thisns,rest) = splitAt (length (types c)) ns
-  in thisns: mknss cs rest
-
-mkpat ns c =
-  if null ns then []
-  else [mypattern (constructor c) (types c) ns]
-
-
-toConstr :: [Doc] -> Body -> Doc
-toConstr ns c =
-  let cn = constructor c
-      ts = types c
-      fvs = nub (concatMap deepvars ts)
-  in
-  text "Constr" <+>
-  fsep [ text "\"" <> text cn <> text "\""
-       , bracketList (map text fvs)
-       , bracketList (map (\v-> text "toHType" <+> v) ns)
-       ]
-
-  where
-
-    deepvars (Arrow t1 t2)  = []
-    --deepvars (Apply t1 t2)  = deepvars t1 ++ deepvars t2
-    deepvars (LApply c ts)  = concatMap deepvars ts
-    deepvars (Var s)        = [s]
-    deepvars (Con s)        = []
-    deepvars (Tuple ts)     = concatMap deepvars ts
-    deepvars (List t)       = deepvars t
-
---first [] fv = error ("cannot locate free type variable "++fv)
---first ((ns,c):cs) fv =
---  let npats = [ (n,pat) | (n,t) <- zip ns (types c)
---                        , (True,pat) <- [ find fv t ]
---              ]
---  in
---  if null npats then
---       first cs fv
---  else let (n,pat) = head npats
---       in parens pat <+> text "= toHType" <+> n
---
---  where
---
---    find :: String -> Type -> (Bool,Doc)
---    find v (Arrow t1 t2)  = (False,error "can't ShowXML for arrow type")
---    find v (Apply t1 t2)  = let (tf1,pat1) = find v t1
---                                (tf2,pat2) = find v t2
---                            in perhaps (tf1 || tf2)
---                                       (pat1 <+> snd (perhaps tf2 pat2))
---    find v (LApply c ts)  = let (_,cpat) = find v c
---                                tfpats = map (find v) ts
---                                (tfs,pats) = unzip tfpats
---                            in perhaps (or tfs)
---                                       (parens (cpat <+>
---                                                bracketList (map (snd.uncurry perhaps) tfpats)))
---    find v (Var s)        = perhaps (v==s) (text v)
---    find v (Con s)        = (False, text "Defined" <+>
---                                    text "\"" <> text s <> text "\"")
---    find v (Tuple ts)     = let tfpats = map (find v) ts
---                                (tfs,pats) = unzip tfpats
---                            in perhaps (or tfs)
---                                       (parens (text "Tuple" <+>
---                                                bracketList (map (snd.uncurry perhaps) tfpats)))
---    find v (List t)       = let (tf,pat) = find v t
---                            in perhaps tf (parens (text "List" <+> pat))
---    perhaps tf doc = if tf then (True,doc) else (False,text "_")
-
-simplest typ cs fv =
-  let npats = [ (depth,(n,pat)) | (ns,c) <- cs
-                                , (n,t) <- zip ns (types c)
-                                , (depth, pat) <- [ find fv t ]
-              ]
-      (_,(n,pat)) = foldl closest (Nothing,error "free tyvar not found") npats
-  in
-  parens pat <+> text "= toHType" <+> n
-
-  where
-
-    find :: String -> Type -> (Maybe Int,Doc)
-    find v (Arrow t1 t2)  = (Nothing,error "can't derive Haskell2XML for arrow type")
---    find v (Apply t1 t2)  = let (d1,pat1) = find v t1
---                                (d2,pat2) = find v t2
---                            in perhaps (combine [d1,d2])
---                                       (pat1 <+> snd (perhaps d2 pat2))
-    find v (LApply c ts)
-        | c == (Con typ)  = (Nothing, text "_")
-        | otherwise       = let (_,cpat)  = find v c
-                                dpats     = map (find v) ts
-                                (ds,pats) = unzip dpats
-                            in perhaps (combine ds)
-                                       (cpat <+>
-                                        bracketList (map (snd.uncurry perhaps) dpats) <+>
-                                        text "_")
-    find v (Var s)        = perhaps (if v==s then Just 0 else Nothing) (text v)
-    find v (Con s)        = (Nothing, text "Defined" <+>
-                                      text "\"" <> text s <> text "\"")
-    find v (Tuple ts)     = let dpats = map (find v) ts
-                                (ds,pats) = unzip dpats
-                            in perhaps (combine ds)
-                                       (text "Tuple" <+>
-                                        bracketList (map (snd.uncurry perhaps) dpats))
-    find v (List t)       = let (d,pat) = find v t
-                            in perhaps (inc d) (text "List" <+> parens pat)
-
-    perhaps Nothing doc   = (Nothing, text "_")
-    perhaps jn doc        = (jn,doc)
-    combine ds   = let js = [ n | (Just n) <- ds ]
-                   in if null js then Nothing else inc (Just (minimum js))
-    inc Nothing  = Nothing
-    inc (Just n) = Just (n+1)
-
-    closest :: (Maybe Int,a) -> (Maybe Int,a) -> (Maybe Int,a)
-    closest (Nothing,_)  b@(Just _,_) = b
-    closest a@(Just n,_) b@(Just m,_) | n< m  = a
-                                      | m<=n  = b
-    closest a b = a
-
-
-
-showsfn n ns cn =
-  let cons = constructor cn
-      typ  = types cn
-      sc   = parens (text "showConstr" <+> text (show n) <+>
-                     parens (text "toHType" <+> text "v"))
-      cfn []  = text "[]"
-      cfn [x] = parens (text "toContents" <+> x)
-      cfn xs  = parens (text "concat" <+> bracketList (map (text "toContents" <+>) xs))
-  in
-  text "toContents" <+>
-  text "v@" <> mypattern cons typ ns <+> text "=" $$
-  nest 4 (text "[mkElemC" <+> sc <+> cfn ns <> text "]")
-
-----
---  text "fromContents (CElem (Elem constr [] cs):etc)" $$
-----
-readsfn n ns cn =
-  let cons   = text (constructor cn)
-      typ    = types cn
-      num    = length ns - 1
-      str d  = text "\"" <> d <> text "\""
-      trails = take num (map text [ ['c','s',y,z] | y <- ['0'..'9']
-                                                  , z <- ['0'..'9'] ])
-      cfn x  = parens (text "fromContents" <+> x)
-      (init,[last]) = splitAt num ns
-      something = parens (
-                    text "\\" <> parenList [last, text "_"] <> text "->" <+>
-                    parens (cons <+> hsep ns <> text "," <+> text "etc") )
-      mkLambda (n,cv) z = parens (
-                            text "\\" <> parenList [n,cv] <> text "->" <+>
-                            fsep [z, cfn cv] )
-  in
-  nest 4 (
-    text "|" <+> str cons <+> text "`isPrefixOf` constr =" $$
-    nest 4 (
-      if null ns then parenList [cons, text "etc"]
-      else fsep [ foldr mkLambda something (zip init trails)
-                , cfn (text "cs")]
-    )
-  )
-  -- Constructors are matched with "isPrefixOf" rather than "=="
-  -- because of parametric polymorphism.  For a datatype
-  --        data A x = A | B x
-  -- the XML tags will be <A>, <B-Int>, <B-Bool>, <B-Maybe-Char> etc.
-  -- However prefix-matching presents a problem for types like
-  --        data C = C | CD
-  -- because (C `isPrefixOf`) matches both constructors.  The solution
-  -- (implemented by "preorder") is to order the constructors such that
-  -- <CD> is matched before <C>.
-
-preorder cs =
-    map snd . reverse . sortBy (\(a,_) (b,_)-> compare a b) . zip (map constructor cs)
-
-
---
-
-instanceheader cls dat =
-  let fv     = vars dat
-      tycon  = name dat
-      ctx    = map (\v-> text cls <+> text v)
-      parenSpace = parens . hcat . sepWith space
-  in
-  hsep [ text "instance"
-       , opt fv (\v -> parenList (ctx v) <+> text "=>")
-       , text cls
-       , opt1 (texts (tycon: fv)) parenSpace id
-       , text "where"
-       ]
-
-mypattern :: Constructor -> [a] -> [Doc] -> Doc
-mypattern c l ns =
-  if null l then text c
-  else parens (hsep (text c : take (length l) ns))
rmfile ./DerivingDrift/UserRuleXml.hs
hunk ./DerivingDrift/UserRules.hs 1
--- stub module to add your own rules.
-module UserRules(userRules) where
-
-import DerivingDrift.RuleUtils(RuleDef) -- gives some examples
-
-import UserRuleBinary
-import UserRuleXml
-import UserRulesGeneric
-import UserRuleGhcBinary
-import qualified DerivingDrift.RuleUtility
-import qualified RuleFunctorM
-import qualified RuleMonoid
-
-
--- add your rules to this list
-userRules :: [RuleDef]
-userRules = userRulesXml ++ userRulesBinary ++ userRulesGeneric ++ userRulesGhcBinary  ++ RuleUtility.rules ++ RuleFunctorM.rules ++ RuleMonoid.rules
-
rmfile ./DerivingDrift/UserRules.hs
hunk ./DerivingDrift/UserRulesGeneric.hs 1
-
-module UserRulesGeneric(userRulesGeneric) where
-
--- import StandardRules
-import DerivingDrift.RuleUtils
-import List(intersperse)
-
-
-userRulesGeneric :: [RuleDef]
-userRulesGeneric =  [
-    ("ATermConvertible", atermfn, "Representation", "encode terms in the ATerm format", Nothing),
-    ("Typeable", typeablefn, "General", "derive Typeable for Dynamic", Nothing),
-    ("Term", dyntermfn, "Generics","Strafunski representation via Dynamic", Nothing),
-    ("HFoldable", hfoldfn, "Generics", "Strafunski hfoldr", Nothing),
-    ("Observable", observablefn, "Debugging", "HOOD observable", Nothing)
-    ]
-
-
-
--- useful helper things
-
-addPrime doc = doc <> (text "'")
-
-ppCons cv c = mkpattern (constructor c) (types c) cv
-
-namesupply   = [text [x,y] | x <- ['a' .. 'z'],
-                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
-mknss []     _  = []
-mknss (c:cs) ns =
-  let (thisns,rest) = splitAt (length (types c)) ns
-  in thisns: mknss cs rest
-
-mkpattern :: Constructor -> [a] -> [Doc] -> Doc
-mkpattern c l ns =
-  if null l then text c
-  else parens (hsep (text c : take (length l) ns))
-
-instanceheader cls dat =
-  let fv     = vars dat
-      tycon  = name dat
-      ctx    = map (\v-> text cls <+> text v)
-      parenSpace = parens . hcat . sepWith space
-  in
-  hsep [ text "instance"
-       , opt fv (\v -> parenList (ctx v) <+> text "=>")
-       , text cls
-       , opt1 (texts (tycon: fv)) parenSpace id
-       , text "where"
-       ]
-
-doublequote str
-  = "\""++str++"\""
-
-mkList :: [Doc] -> Doc
-mkList xs = text "[" <> hcat (punctuate comma xs) <> text "]"
-
-typeablefn :: Data -> Doc
-typeablefn  dat
-  = tcname <+> equals <+> text "mkTyCon" <+> text (doublequote $ name dat) $$
-    instanceheader "Typeable" dat $$ block (
-	[ text "typeOf x = mkAppTy"  <+>
-	  tcname <+>
-	  text "[" <+> hcat (sepWith comma (map getV' (vars dat))) <+> text "]" $$
-	  wheres ])
-    where
-      tcname = text ("_tc_" ++ (name dat)  ++ "Tc")
-      wheres = where_decls (map getV (vars dat))
-      tpe    = text (name dat) <+> hcat (sepWith space (map text (vars dat)))
-      getV' var
-        = text "typeOf" <+> parens (text "get" <> text var <+> text "x")
-      getV var
-        = text "get" <> text var <+> text "::" <+> tpe <+> text "->" <+> text var $$
-          text "get" <> text var <+> equals <+> text "undefined"
-
-where_decls [] = empty
-where_decls ds = text "  where" $$ block ds
-
-dyntermfn :: Data -> Doc
-dyntermfn dat = instanceheader "Term" dat $$ block [
-    text "explode (x::"<>a<>text ") = TermRep (toDyn x, f x, g x) where", block (
-	zipWith f cvs cs ++ zipWith g cvs cs
-	)] where
-	    f cv c = text "f" <+> ppCons cv c <+> equals <+> mkList (map (text "explode" <+>) $ vrs c cv)
-	    g cv c = text "g" <+> ppCons underscores c <+> text "xs" <+>
---		text "|" <+> mkList (vrs c cv) <+> text "<- TermRep.fArgs xs" <+> equals <+> text "toDyn" <+> parens (parens (text (constructor c) <+> hsep (map h (vrs c cv))) <> text "::a" )
-		equals <+> text "case TermRep.fArgs xs of" <+> mkList (vrs c cv) <+> text "->" <+> text "toDyn" <+> parens (parens (text (constructor c) <+> hsep (map h (vrs c cv))) <> text "::"<>a<>text "" ) <> text " ; _ -> error \"Term explosion error.\""
-	    h n = parens $ text "TermRep.fDyn" <+> n
-	    cvs = mknss cs namesupply
-	    cs = body dat
-	    vrs c cv = take (length (types c)) cv
-	    underscores = repeat $ text "_"
-	    a = text (name dat) <+> hcat (sepWith space (map text (vars dat)))
-
-
--- begin observable
-
-observablefn :: Data -> Doc
-observablefn  dat =
-  let cs  = body dat
-      cvs = mknss cs namesupply
-  in
-  instanceheader "Observable" dat $$
-  block (zipWith observefn cvs cs)
-
-observefn cv c =
-    text "observer" <+> ppCons cv c <+> text "= send"  <+> text (doublequote (constructor c)) <+> parens (text "return" <+> text (constructor c) <+> hsep (map f (take (length (types c)) cv))) where
-    f n = text "<<" <+> n
-
-
-
-
-
-
--- begin of ATermConvertible derivation
--- Author: Joost.Visser@cwi.nl
-
-atermfn dat
-  = instanceSkeleton "ATermConvertible"
-      [ (makeToATerm (name dat),defaultToATerm)
-      , (makeFromATerm (name dat),defaultFromATerm (name dat))
-      ]
-      dat
-
-makeToATerm name body
-  = let cvs = head (mknss [body] namesupply)
-    in text "toATerm" <+>
-       ppCons cvs body <+>
-       text "=" <+>
-       text "(AAppl" <+>
-       text (doublequote (constructor body)) <+>
-       text "[" <+>
-       hcat (intersperse (text ",") (map childToATerm cvs)) <+>
-       text "])"
-defaultToATerm
-  = empty
-childToATerm v
-  = text "toATerm" <+> v
-
-makeFromATerm name body
-  = let cvs = head (mknss [body] namesupply)
-    in text "fromATerm" <+>
-       text "(AAppl" <+>
-       text (doublequote (constructor body)) <+>
-       text "[" <+>
-       hcat (intersperse (text ",") cvs) <+>
-       text "])" <+>
-       text "=" <+> text "let" <+>
-       vcat (map childFromATerm cvs) <+>
-       text "in" <+>
-       ppCons (map addPrime cvs) body
-defaultFromATerm name
-  = hsep $ texts ["fromATerm", "u", "=", "fromATermError", (doublequote name), "u"]
-childFromATerm v
-  = (addPrime v) <+> text "=" <+> text "fromATerm" <+> v
-
--- end of ATermConvertible derivation
-
--- begin of HFoldable derivation
--- Author: Joost Visser and Ralf Laemmel
-
-hfoldfn dat
-  = instanceSkeleton "HFoldable"
-      [ (make_hfoldr (name dat), default_hfoldr),
-        (make_conof (name dat), default_conof)
-      ]
-      dat
-
-make_hfoldr name body
-  = let cvs = head (mknss [body] namesupply)
-    in text "hfoldr'" <+>
-       text "alg" <+>
-       ppCons cvs body <+>
-       text "=" <+>
-       foldl (\rest var -> text "hcons alg" <+> var  <+> parens rest)
-             (text "hnil alg" <+> text (constructor body))
-             cvs
-
-default_hfoldr
-  = empty
-
-make_conof name body
-  = let cvs = head (mknss [body] namesupply)
-    in text "conOf" <+>
-       ppCons cvs body <+>
-       text "=" <+>
-       text (doublequote (constructor body))
-
-default_conof
-  = empty
-
-
rmfile ./DerivingDrift/UserRulesGeneric.hs