Generic.hs

module Rules.Generic(rules) where

-- import StandardRules
import RuleUtils
import Data.List(intersperse)


rules :: [RuleDef]
rules =  [
    ("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 = mkTyConApp"  <+>
	  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