hgom-0.5.1: Gom/CodeGen/Constructors.hs
------------------------------------------------------------------
-- |
-- Module : Gom.CodeGen.Constructors
-- Copyright : (c) Paul Brauner 2009
-- (c) Emilie Balland 2009
-- (c) INRIA 2009
-- Licence : GPL (see COPYING)
--
-- Maintainer : paul.brauner@inria.fr
-- Stability : provisional
-- Portability : non-portable (requires generalized newtype deriving)
--------------------------------------------------------------------
module Gom.CodeGen.Constructors (
compConstructor,
compAbstractVariadic
) where
import Gom.Sig
import Gom.Config
import Gom.FileGen
import Gom.SymbolTable
import Gom.CodeGen.Common
import Text.PrettyPrint.Leijen
import Control.Monad.Reader
import Data.List(intersperse)
-- | Given a variadic constructor @VC@, generates an abstract class @VC.java@.
compAbstractVariadic :: CtorId -> Gen FileHierarchy
compAbstractVariadic vc = do cl <- body
return $ Class (show vc) cl
where ifP = flip (ifConfM parsers) (return empty)
body = do co <- askSt (codomainOf vc)
qto <- qualifiedSort co
tsb <- compToStringBuilderVariadic vc
pa <- ifP $ compParseVariadic vc
pat <- ifP $ compParseVariadicTail vc
return $ rClass (public <+> abstract) (pretty vc)
(Just qto) [] (vcat [tsb,pa,pat])
-- | Given a variadic constructor @List(T*)@, generates
--
-- > public void toStringBuilder(java.lang.StringBuilder buf) {
-- > buffer.append("List(");
-- > if(this instanceof mod.types.codom.ConsList) {
-- > mod.types.List cur = this;
-- > while(cur instanceof mod.types.codom.ConsList) {
-- > mod.types.T elem = cur.getHeadList();
-- > cur = cur.getTailList();
-- > elem.toStringBuilder(buf);
-- > if(cur instanceof mod.types.codom.ConsList) {
-- > buf.append(",");
-- > }
-- > }
-- > if(!(cur instanceof mod.types.codom.EmptyList)) {
-- > buf.append(",");
-- > cur.toStringBuilder(buf);
-- > }
-- > }
-- > buf.append(")");
-- > }
compToStringBuilderVariadic :: CtorId -> Gen Doc
compToStringBuilderVariadic vc = do
qcons <- qualifiedCtor cons
qnil <- qualifiedCtor nil
co <- askSt (codomainOf vc)
dom <- askSt (fieldOf vc)
qco <- pretty `fmap` qualifiedSort co
qdom <- pretty `fmap` qualifiedSort dom
let mid = middle qco qcons qnil qdom (isBuiltin dom)
return $ rMethodDef public void toSB
[jStringBuilder <+> buf]
(rBody [pre,mid,post])
where bapp arg = rMethodCall buf (text "append") [arg]
cons = prependCons vc
nil = prependEmpty vc
pre = bapp $ dquotes (pretty vc <> lparen)
post = bapp $ dquotes rparen
comm = bapp $ dquotes comma
cur = text "__cur"
elm = text "__elem"
getH = text "getHead" <> pretty vc
getT = text "getTail" <> pretty vc
toSB = text "toStringBuilder"
buf = text "__buf"
jneg = (text "!" <>) . parens
middle qco qc qn dom btin =
rIfThen (this <+> instanceof <+> qc) $ rBody
[qco <+> cur <+> equals <+> this,
rWhile (cur <+> instanceof <+> qc) $ rBody
[dom <+> elm <+> equals <+> rMethodCall cur getH [],
cur <+> equals <+> rMethodCall cur getT [],
if btin then bapp elm else rMethodCall elm toSB [buf],
rIfThen (cur <+> instanceof <+> qc) (rBody [comm])],
rIfThen (jneg $ cur <+> instanceof <+> qn) $ rBody
[comm, rMethodCall cur toSB [buf]]]
-- | Given a sort @s@, @parseRecCall arg s@ generates
--
-- * @arg.parses()@ if @s@ is a builtin,
--
-- * @mod.types.s.parse(arg)@ otherwise
parseRecCall :: Doc -> SortId -> Gen Doc
parseRecCall arg s = do
qs <- qualifiedSort s
return $ if isBuiltin s
then rMethodCall arg (text "parse" <> pretty s) []
else rMethodCall qs (text "parse") [arg]
-- | Given a constructor @C(x1:T1,...,xn:Tn)@,
-- of codomain @Co@, generates
--
-- > final static mod.types.Co parseArgs(mod.Parser par) {
-- > par.parseLpar();
-- > mod.types.T1 x1 = mod.types.T1.parse(par);
-- > par.parseComma();
-- > ...
-- > par.parseComma();
-- > mod.types.Tn xn = mod.types.Tn.parse(par);
-- > par.parseRpar();
-- > return mod.types.Co.C.make(x1,...,xn);
-- > }
compParseConstructor :: CtorId -> Gen Doc
compParseConstructor c = do
pr <- packagePrefix
co <- askSt (codomainOf c)
qco <- qualifiedSort co
recs <- iterOverFields call (intersperse pcomm) c
post <- postM
return $ rMethodDef (final <+> static <+> public)
qco (text "parseArgs")
[pars pr <+> arg] (rBody (pre:recs++post))
where pars pr = pr <> dot <> text "Parser"
arg = text "__par"
pcomm = rMethodCall arg (text "parseComma") []
call f s = do
qs <- qualifiedSort s
rec <- parseRecCall arg s
return $ qs <+> _u (pretty f) <+> equals <+> rec
pre = rMethodCall arg (text "parseLpar") []
postM = do qc <- qualifiedCtor c
fis <- map (_u . pretty . fst) `fmap` askSt (fieldsOf c)
return [rMethodCall arg (text "parseRpar") [],
jreturn <+> rMethodCall qc (text "make") fis]
-- | Given a variadic constructor @VC(T*)@,
-- of codomain @Co@, generates
--
-- > static public mod.types.Co parseArgs(mod.Parser par) {
-- > par.parseLpar();
-- > if (par.isRpar()) {
-- > par.parseRpar();
-- > return mod.types.vc.EmptyVC.make();
-- > } else {
-- > mod.types.T head = mod.types.T.parse(par)
-- > mod.types.Co tail = mod.types.vc.VC.parseTail(par);
-- > par.parseRpar();
-- > return mod.types.vc.ConsVC.make(head,tail);
-- > }
-- > }
compParseVariadic :: CtorId -> Gen Doc
compParseVariadic vc = do
pr <- packagePrefix
co <- askSt (codomainOf vc)
qco <- qualifiedSort co
qvc <- qualifiedCtor vc
qcons <- qualifiedCtor (prependCons vc)
qnil <- qualifiedCtor (prependEmpty vc)
phead <- parseHead
return $ rMethodDef
(static <+> public) qco (text "parseArgs") [pars pr <+> arg]
(vcat [text "__par.parseLpar();",
rIfThenElse (text "__par.isRpar()")
(rBody [text "__par.parseRpar()", makeNil qnil])
(rBody [phead, parseTail qco qvc,
text "__par.parseRpar()", makeCons qcons])])
where pars pr = pr <> dot <> text "Parser"
arg = text "__par"
parseHead = do dom <- askSt (fieldOf vc)
qdom <- qualifiedSort dom
rec <- parseRecCall arg dom
return $ qdom <+> text "__head" <+> equals <+> rec
retMake q as = jreturn <+> rMethodCall q (text "make") as
makeCons qc = retMake qc [text "__head", text "__tail"]
makeNil qn = retMake qn []
parseTail qco qvc = qco <+> text "__tail" <+> equals <+>
rMethodCall qvc (text "parseTail") [arg]
-- | Given a variadic constructor @VC(T*)@,
-- of codomain @Co@, generates
--
-- > static public mod.types.Co parseTail(mod.Parser par) {
-- > if (par.isComma()) {
-- > par.parseComma();
-- > mod.types.T head = mod.types.T.parse(par)
-- > mod.types.Co tail = mod.types.vc.VC.parseTail(par);
-- > return mod.types.vc.ConsVC.make(head,tail);
-- > } else {
-- > return mod.types.vc.EmptyVC.make();
-- > }
-- > }
compParseVariadicTail :: CtorId -> Gen Doc
compParseVariadicTail vc = do
pr <- packagePrefix
co <- askSt (codomainOf vc)
qco <- qualifiedSort co
qvc <- qualifiedCtor vc
qcons <- qualifiedCtor (prependCons vc)
qnil <- qualifiedCtor (prependEmpty vc)
phead <- parseHead
return $ rMethodDef
(static <+> public) qco (text "parseTail") [pars pr <+> arg]
(rIfThenElse (text "__par.isComma()")
(rBody [text "__par.parseComma()", phead,
parseTail qco qvc ,makeCons qcons])
(makeNil qnil <> semi))
where pars pr = pr <> dot <> text "Parser"
arg = text "__par"
parseHead = do dom <- askSt (fieldOf vc)
qdom <- qualifiedSort dom
rec <- parseRecCall arg dom
return $ qdom <+> text "__head" <+> equals <+> rec
retMake q as = jreturn <+> rMethodCall q (text "make") as
makeCons qc = retMake qc [text "__head", text "__tail"]
makeNil qn = retMake qn []
parseTail qco qvc = qco <+> text "__tail" <+> equals <+>
rMethodCall qvc (text "parseTail") [arg]
-- | Given a non-variadic constructor @C@, generates a concrete class @C.java@.
compConstructor :: CtorId -> Gen FileHierarchy
compConstructor c = do mem <- compMembersOfConstructor c
smem <- ifSh $ compSharingMembers c
ctor <- compCtorOfConstructor c
mak <- compMakeOfConstructor c
get <- compGettersOfConstructor c
set <- compSettersOfConstructor c
tos <- ifNG $ compToStringBuilder c
toh <- ifConfM haskell (compToHaskellBuilder c) rempty
eqs <- ifConfM sharing (compEquiv c) (compEquals c)
hac <- ifConf sharing hashCodeMethod empty
dup <- ifSh $ compDuplicate c
ini <- ifSh $ compInit c
inh <- ifSh $ compInitHash c
haf <- ifSh $ compHashFun c
gcc <- ifV $ compGetChildCount c
gca <- ifV $ compGetChildAt c
gcs <- ifV $ compGetChildren c
sca <- ifV $ compSetChildAt c
scs <- ifV $ compSetChildren c
par <- ifP $ compParseConstructor c
ran <- ifR $ compMakeRandomConstructor c
dep <- ifD $ compDepthConstructor c
siz <- ifSi $ compSizeConstructor c
let isc = compIsX c
let syn = compSymbolName c
let body = vcat [mem,smem,ctor,mak,syn,
get,set,tos,toh,eqs,hac,
dup,ini,inh,haf,isc,gcc,gca,
gcs,sca,scs,par,ran,dep,siz]
cls <- wrap body
return $ Class (show c) cls
where rempty = return empty
ifV = flip (ifConfM visit ) rempty
ifSh = flip (ifConfM sharing) rempty
ifP = flip (ifConfM parsers) rempty
ifR = flip (ifConfM random ) rempty
ifD = flip (ifConfM depth ) rempty
ifSi = flip (ifConfM size ) rempty
-- ifNG == if not generated
ifNG a = askSt (isGenerated c) >>= maybe a (const rempty)
wrap b = do
gen <- askSt (isGenerated c)
let rcls d = rClass public (pretty c) (Just d) [] b
case gen of Nothing -> do co <- askSt (codomainOf c)
qco <- qualifiedSort co
return $ rcls qco
Just bc -> do qbc <- qualifiedCtor bc
return $ rcls qbc
-- | Given a non-variadic constructor @C(x1:T1,..,xn:Tn)@,
-- generates @m.types.T1 x1; ...; m.types.Tn xn;@
compMembersOfConstructor :: CtorId -> Gen Doc
compMembersOfConstructor c = iterOverFields rdr rBody c
where rdr f s = do qs <- qualifiedSort s
return $ private <+> qs <+> _u (pretty f)
-- | Given a non-variadic constructor @C(x1:T1,..,xn:Tn)@,
-- generates:
--
-- > private int hashCode;
-- > private static C proto = new C();
-- > private static int nameHash =
-- > shared.HashFunctions.stringHashFunction(mod.types.s.c,n);
compSharingMembers :: CtorId -> Gen Doc
compSharingMembers c = do
qc <- qualifiedCtor c
len <- length `fmap` askSt (fieldsOf c)
return $ rBody [text "private static int nameHash" <+> equals <+>
rMethodCall (text "shared.HashFunctions")
(text "stringHashFunction")
[dquotes qc, int len],
text "private int hashCode",
text "private static" <+> pretty c <+>
text "__proto = new" <+> pretty c <> text "()"]
-- | Given a non-variadic constructor @C(x1:T1,..,xn:Tn)@,
-- generates the constructor:
--
-- > private C(m.types.T1 x1, ..., m.types.Tn xn) {
-- > this.x1 = x1;
-- > ...
-- > this.xn = xn;
-- > }
compCtorOfConstructor :: CtorId -> Gen Doc
compCtorOfConstructor c = ifConfM sharing ctorShr ctorNoShr
where ctorShr = return $ rMethodDef private empty (pretty c) [] empty
ctorNoShr = do fis <- askSt (fieldsOf c)
a <- mapM rdr1 fis
let b = rBody $ map rdr2 fis
return $ rMethodDef private empty (pretty c) a b
where rdr1 (f,s) = do qs <- qualifiedSort s
return $ qs <+> _u (pretty f)
rdr2 (f,_) = this <> dot <> _u (pretty f) <+>
equals <+> _u (pretty f)
-- | Given a non-variadic constructor @C(x1:T1,..,xn:Tn)@,
-- generates the make method:
--
-- > public static C make(m.types.T1 x1, ..., m.types.Tn xn) {
-- > proto.initHashCode(x1,..,xn);
-- > return (C) factory.build(proto);
-- > }
--
-- or the following if @--noSharing@ has been toggled:
--
-- > public static C make(m.types.T1 x1, ..., m.types.Tn xn) {
-- > return new C(x1, ..., xn);
-- > }
compMakeOfConstructor :: CtorId -> Gen Doc
compMakeOfConstructor c = ifConfM sharing cmakes cmake
where -- the sharing case
cmakes = do cfs <- cfields
let call = rMethodCall proto inith (map (pretty.fst) cfs)
let ret = jreturn <+> parens (pretty c) <+> build
makeDef $ rBody [call,ret]
where proto = text "__proto"
inith = text "initHashCode"
build = text "factory.build(__proto)"
-- the no sharing case
cmake = do cfs <- cfields
let b = newC (map (pretty . fst) cfs) <> semi
makeDef b
where newC fs = jreturn <+> rConstructorCall (pretty c) fs
-- takes a body bd and returns public static C make(...) { bd }
makeDef bd = do cfs <- cfields
a <- mapM rdr cfs
return $ rMethodDef (public <+> static)
(pretty c) (text "make") a bd
where rdr (f,s) = do qs <- qualifiedSort s
return $ qs <+> (text .show) f
-- the fields of c
cfields = askSt (fieldsOf c)
-- | Given a non-variadic constructor @C(x1:T1,..,xn:Tn)@,
-- generates the methods:
--
-- > public m.types.T1 getx1() { return x1; }
-- > ...
-- > public m.types.Tn getxn() { return xn; }
compGettersOfConstructor :: CtorId -> Gen Doc
compGettersOfConstructor = iterOverFields getter vcat
where getter f s = do qs <- qualifiedSort s
let fun = text "get" <> pretty f
let b = rBody [jreturn <+> _u (pretty f)]
return $ rMethodDef public qs fun [] b
-- | Given a non-variadic constructor @C(x1:T1,..,xn:Tn)@,
-- generates the methods:
--
-- > public void setx1(m.types.T1 x1)
-- > { this.x1 = x1; }
-- > ...
-- > public void setxn(m.types.Tn xn)
-- > { this.xn = xn; }
compSettersOfConstructor :: CtorId -> Gen Doc
compSettersOfConstructor = iterOverFields setter vcat
where setter f s = do qs <- qualifiedSort s
let fun = text "set" <> pretty f
let a = [pretty qs <+> _u (pretty f)]
let b = rBody [this <> dot <> _u (pretty f)
<+> equals <+> _u (pretty f)]
return $ rMethodDef public void fun a b
-- | Given a non-variadic constructor @C(x1:T1,..,xn:Tn)@,
-- generates
--
-- > public String toStringBuilder(java.lang.StringBuilder buf) {
-- > buffer.append("C(");
-- > x1.toStringBuilder(buf);
-- > buffer.append(",");
-- > ...
-- > buffer.append(",");
-- > xn.toStringBuilder(buf);
-- > buffer.append(")");
-- > }
compToStringBuilder :: CtorId -> Gen Doc
compToStringBuilder c = do rcalls <- iterOverFields rcall id c
return $ rMethodDef
public void (text "toStringBuilder")
[jStringBuilder <+> text "__buf"]
(complete rcalls)
where complete b = rBody $ open : intersperse apcomma b ++ [close]
bapp arg = text "__buf.append" <> parens arg
apcomma = bapp $ dquotes comma
open = bapp $ dquotes (pretty c <> lparen)
close = bapp $ dquotes rparen
rcall x s = return $
if isBuiltin s then renderBuiltin s (_u $ pretty x) (text "__buf")
else rMethodCall (this <> dot <> _u (pretty x))
(text "toStringBuilder")
[text "__buf"]
-- | Given a non-variadic constructor @C(x1:T1,..,xn:Tn)@,
-- generates
--
-- > public String toHaskellBuilder(java.lang.StringBuilder buf) {
-- > buffer.append("(C");
-- > buffer.append(" ");
-- > x1.toStringBuilder(buf);
-- > buffer.append(" ");
-- > ...
-- > buffer.append(" ");
-- > xn.toStringBuilder(buf);
-- > buffer.append(")");
-- > }
compToHaskellBuilder :: CtorId -> Gen Doc
compToHaskellBuilder c = do rcalls <- iterOverFields rcall id c
return $ rMethodDef
public void (text "toHaskellBuilder")
[jStringBuilder <+> text "__buf"]
(complete rcalls)
where complete b = rBody $ open : addspaces b ++ [close]
bapp arg = text "__buf.append" <> parens arg
apspace = bapp $ dquotes space
addspaces = foldr (\x r -> apspace:x:r) []
open = bapp $ dquotes (lparen <> pretty c)
close = bapp $ dquotes rparen
rcall x s = return $
if isBuiltin s then renderBuiltin s (_u $ pretty x) (text "__buf")
else rMethodCall (this <> dot <> _u (pretty x))
(text "toHaskellBuilder")
[text "__buf"]
-- | Given a non-variadic constructor @C(x1:T1,..,xn:Tn)@,
-- @compEquiv C@ generates
--
-- > public boolean equivalent(shared.SharedObject o) {
-- > if (o instanceof C) {
-- > C typed_o = (C) o;
-- > return true &&
-- > this.x1 == o.x1 &&
-- > ...
-- > this.xn == o.xn;
-- > } else {
-- > return false;
-- > }
-- > }
compEquiv :: CtorId -> Gen Doc
compEquiv = compEqAux meth comb jShared
where meth = text "equivalent"
comb lhs rhs = lhs <+> text "==" <+> rhs
-- | Given a non-variadic constructor @C(x1:T1,..,xn:Tn)@,
-- @compEquals C@ generates
--
-- > public boolean equals(java.lang.Object o) {
-- > if (o instanceof C) {
-- > C typed_o = (C) o;
-- > return true &&
-- > this.x1.equals(o.x1) &&
-- > ...
-- > this.xn.equals(o.xn);
-- > } else {
-- > return false;
-- > }
-- > }
compEquals :: CtorId -> Gen Doc
compEquals = compEqAux meth comb jObject
where meth = text "equals"
comb lhs rhs = rMethodCall lhs meth [rhs]
-- | Given a constructor @C(x1:T1,..,xn:Tn)@, generates
--
-- > public shared.SharedObject duplicate() {
-- > C clone = new C();
-- > clone.init(this.x1,..,this.xn,hashCode);
-- > return clone;
-- > }
compDuplicate :: CtorId -> Gen Doc
compDuplicate c = rdr `fmap` askSt (fieldsOf c)
where pc = pretty c
cl = text "__clone"
th = (text "this." <>) . _u . pretty . fst
rdr = rMethodDef public jShared (text "duplicate") [] . body
body fis = rBody
[pc <+> cl <+> equals <+> rConstructorCall pc [],
rMethodCall cl (text "init") (map th fis ++ [text "hashCode"]),
jreturn <+> cl]
-- | Given a constructor @C(x1:T1,..,xn:Tn)@, generates
--
-- > private void init(T1 x1, ..., Tn xn, int hashCode) {
-- > this.x1 = x1;
-- > ...
-- > this.xn = xn;
-- > this.hashCode = hashCode;
-- > }
compInit :: CtorId -> Gen Doc
compInit c = do cfs <- askSt $ fieldsOf c
tfs <- mapM rdr cfs
let args = tfs ++ [text "int __hashCode"]
let body = rBody $ map ass cfs ++ [lastLine]
return $ rMethodDef private void (text "init") args body
where rdr (f,s) = do qs <- qualifiedSort s
return $ qs <+> _u (pretty f)
ass (f,s) = let pf = _u (pretty f)
in this <> dot <> pf <+> equals <+>
if isString s then pf <> text ".intern()" else pf
lastLine = text "this.hashCode = __hashCode"
-- | Given a constructor @C(x1:T1,..,xn:Tn)@, generates
--
-- > private void initHashCode(T1 x1, ..., Tn xn) {
-- > this.x1 = x1;
-- > ...
-- > this.xn = xn;
-- > this.hashCode = hashFunction();
-- > }
compInitHash :: CtorId -> Gen Doc
compInitHash c = do cfs <- askSt $ fieldsOf c
args <- mapM rdr cfs
let body = rBody $ map ass cfs ++ [lastLine]
return $ rMethodDef private void
(text "initHashCode") args body
where rdr (f,s) = do qs <- qualifiedSort s
return $ qs <+> _u (pretty f)
ass (f,s) = let pf = _u (pretty f)
in this <> dot <> pf <+> equals <+>
if isString s then pf <> text ".intern()" else pf
lastLine = text "this.hashCode = hashFunction()"
-- | Auxiliary function for @'compHashFun'@, generates the fields-related part
-- of the @hashFunction@ method.
hashArgs :: [(FieldId,SortId)] -> Int -> [Doc]
hashArgs fis len = zipWith (\i (f,s) -> hashArg i f s) (desc (len -1)) fis
where desc n = n:desc (n-1)
-- | Auxiliary function for @'hashArgs'@, generates the recursive call
-- to the @hashFunction@ method for a non-builin field, ad-hoc magic
-- otherwise.
hashArg :: Int -> FieldId -> SortId -> Doc
hashArg idx fid sid = let res d = char accum <+> text "+=" <+> parens d in
if shift == 0 then res go
else res $ go <+> text "<<" <+> int shift
where go | isILC sid = pfid
| isBoolean sid = pfid <> text "?1:0"
| isFloat sid = text "(int)" <> toInt pfid <> text "^" <>
parens (toInt pfid) <> text ">>>16"
| isDouble sid = text "(int)" <> toLong pfid <> text "^" <>
parens (toLong pfid) <> text ">>>32"
| otherwise = rMethodCall pfid (text "hashCode") []
shift = (idx `mod` 4) * 8
accum = "aaaabbbbcccc" !! (idx `mod` 12)
isILC s = any ($ s) [isInt,isLong,isChar]
toInt x = text "java.lang.Float.floatToIntBits" <> parens x
toLong x = text "java.lang.Double.doubleToLongBits" <> parens x
pfid = this <> dot <> _u (pretty fid)
-- | Given a constructor @C(x1:T1,..,xn:Tn)@, generates
--
-- > protected int hashFunction() {
-- > int a, b, c;
-- > a = 0x9e3779b9;
-- > b = nameHash << 8;
-- > c = n;
-- > hashArgs [(x1,T1),..,(xn,Tn)] n
-- > a -= b; a -= c; a ^= (c >> 13);
-- > b -= c; b -= a; b ^= (a << 8);
-- > c -= a; c -= b; c ^= (b >> 13);
-- > a -= b; a -= c; a ^= (c >> 12);
-- > b -= c; b -= a; b ^= (a << 16);
-- > c -= a; c -= b; c ^= (b >> 5);
-- > a -= b; a -= c; a ^= (c >> 3);
-- > b -= c; b -= a; b ^= (a << 10);
-- > c -= a; c -= b; c ^= (b >> 15);
-- > return c;
-- > }
compHashFun :: CtorId -> Gen Doc
compHashFun c = do
fis <- askSt (fieldsOf c)
let len = length fis
let modif = protected <+> if len == 0 then static else empty
return $ rMethodDef modif jint (text "hashFunction") [] (body fis len)
where body f l = rBody (prologue ++ mid f l ++ epilogue)
prologue = map text ["int a, b, c",
"a = 0x9e3779b9",
"b = nameHash << 8"]
mid f l = (text "c =" <+> int l) : hashArgs f l
epilogue = map text ["a -= b; a -= c; a ^= (c >> 13)",
"b -= c; b -= a; b ^= (a << 8)" ,
"c -= a; c -= b; c ^= (b >> 13)",
"a -= b; a -= c; a ^= (c >> 12)",
"b -= c; b -= a; b ^= (a << 16)",
"c -= a; c -= b; c ^= (b >> 5)" ,
"a -= b; a -= c; a ^= (c >> 3)" ,
"b -= c; b -= a; b ^= (a << 10)",
"c -= a; c -= b; c ^= (b >> 15)",
"return c"]
-- | Given a constructor @c@ of arity @n@, generates
--
-- > public int getChildCount() {
-- > return n;
-- > }
compGetChildCount :: CtorId -> Gen Doc
compGetChildCount c = do ar <- length `fmap` askSt (fieldsOf c)
return $ wrap ar
where wrap n = rMethodDef public jint (text "getChildCount")
[] (jreturn <+> int n <> semi)
-- | Given a constructor @c@ of fields @x1,..,xn@ generates
--
-- > public tom.library.sl.Visitable getChildAt(int n) {
-- > switch(n) {
-- > case 0: return this.x1;
-- > ...
-- > case n-1: return this.xn;
-- > default: throw new IndexOutOfBoundsException();
-- > }
-- > }
--
-- Common.Builtins are boxed in @tom.library.sl.VisitableBuiltin@.
compGetChildAt :: CtorId -> Gen Doc
compGetChildAt c = do fis <- askSt (fieldsOf c)
let cs = zip (map int [0..]) (map cook fis)
let arg = text "n"
return $ rMethodDef
public jVisitable (text "getChildAt")
[jint <+> arg] (body arg cs)
where cook (f,s) = jreturn <+> wrap (this <> dot <> _u (pretty f)) s <> semi
body n cs = rSwitch n cs (Just outOfBounds)
outOfBounds = text "throw new IndexOutOfBoundsException();"
wrap f s | isBuiltin s = rConstructorCall (rWrapBuiltin qs) [f]
| otherwise = f
where qs = qualifiedBuiltin s
-- | Given a constructor @c@ of fields @x1,..,xn@ generates
--
-- > public tom.library.sl.Visitable[] getChildren() {
-- > return new tom.library.sl.Visitable[] {
-- > this.x1, ..., this.xn
-- > };
-- > }
--
-- Common.Builtins are boxed in @tom.library.sl.VisitableBuiltin@.
compGetChildren :: CtorId -> Gen Doc
compGetChildren c = do fis <- askSt (fieldsOf c)
return $ rMethodDef public jVisitableArray
(text "getChildren")
[] (body fis)
where body fs = let cs = align . sep . punctuate comma $ map child fs
in jreturn <+> new <+> jVisitableArray <+> ibraces cs <> semi
child (f,s) =
if isBuiltin s then rConstructorCall (rWrapBuiltin qs) [df] else df
where qs = qualifiedBuiltin s
df = this <> dot <> _u (pretty f)
-- | Given a constructor @c@ of fields @x1,..,xn@ generates
--
-- > public tom.library.sl.Visitable setChildAt(tom.library.sl.Visitable v) {
-- > switch(n) {
-- > case 0: return c.make((m.foo.T1) x1,this.x2,..,this.xn);
-- > ...
-- > case n-1: return c.make(this.x1,...,(m.foo.Tn) this.xn);
-- > default: throw new IndexOutOfBoundsException();
-- > }
-- > }
--
-- Common.Builtins are unboxed from @tom.library.sl.VisitableBuiltin@.
compSetChildAt :: CtorId -> Gen Doc
compSetChildAt c = do fis <- askSt (fieldsOf c)
fis' <- mapM set (parts fis)
let cs = zip (map int [0..]) fis'
return $ rMethodDef
public jVisitable (text "setChildAt")
[jint <+> text "__n", jVisitable <+> text "__v"]
(body cs)
where body cs = rSwitch (text "__n") cs (Just outOfBounds)
outOfBounds = text "throw new IndexOutOfBoundsException();"
set (xs1,(_,t),xs2) =
let f (x,_) = this <> dot <> _u (pretty x)
dxs1 = map f xs1
dxs2 = map f xs2
in do dx <- cast t
let args = dxs1++[dx]++dxs2
let call = rMethodCall (pretty c) (text "make") args
return $ jreturn <+> call <> semi
parts l = go [] l where go _ [] = []
go xs [x] = [(xs,x,[])]
go xs (x:ys) = (xs,x,ys) : go (xs++[x]) ys
cast t = if isBuiltin t
then let qbt = rWrapBuiltin (qualifiedBuiltin t)
cas = parens (parens qbt <+> text "__v")
in return $ rMethodCall cas (text "getBuiltin") []
else do qt <- qualifiedSort t
return $ parens qt <+> text "__v"
-- | Given a constructor @c@ of fields @x1,..,xn@ generates
--
-- > public tom.library.sl.Visitable
-- > setChildren(tom.library.sl.Visitable[] cs) {
-- > if (cs.length == n-1 &&
-- > cs[0] instanceof T0 &&
-- > ..
-- > cs[n] instanceof Tn) {
-- > return c.make(cs[0],..,cs[n])
-- > } else {
-- > throw new IndexOutOfBoundsException();
-- > }
-- > }
--
-- Common.Builtins are unboxed from @tom.library.sl.VisitableBuiltin@.
compSetChildren :: CtorId -> Gen Doc
compSetChildren c = do cs <- askSt (fieldsOf c)
csn <- zipWithM cook [0..] cs
let cd = cond csn
let bd = body csn
let ite = rIfThenElse cd bd er
return $ rMethodDef
public jVisitable (text "setChildren")
[jVisitableArray <+> text "__cs"] ite
where cond csn = let cl = checkLen (length csn)
ci = map checkInstance csn
in align . fillSep $ intersperse (text "&&") (cl:ci)
checkLen n = text "__cs.length ==" <+> int n
checkInstance (n,t,qt) = nth n <+> instanceof <+> td
where td = if isBuiltin t
then text "tom.library.sl.VisitableBuiltin"
else pretty qt
body csn = let call = rMethodCall (pretty c) (text "make") (map r csn)
in jreturn <+> call <> semi
where r (n,t,qt) | isBuiltin t = rMethodCall cas
(text "getBuiltin") []
| otherwise = parens (pretty qt) <+> nth n
where wqt = rWrapBuiltin (qualifiedBuiltin t)
cas = parens (parens wqt <+> nth n)
er = text "throw new IndexOutOfBoundsException();"
nth n = text "__cs" <> brackets (int n)
cook n (_,t) = do qt <- qualifiedSort t
return (n,t,qt)
-- | Given a constructor C, generates
--
-- > public boolean isC() { return true; }
compIsX :: CtorId -> Doc
compIsX c = let fun = text "is" <> pretty c
b = rBody [jreturn <+> true]
in rMethodDef public jboolean fun [] b
-- | @compSymbolName c@ renders
--
-- > public String symbolName() {
-- > return "c";
-- > }
compSymbolName
:: CtorId -- ^ constructor name
-> Doc
compSymbolName c =
text "public String symbolName()" <+>
ibraces (rBody [jreturn <+> dquotes (pretty c)])
-- | Auxiliary function for 'compEquals' and 'compEquiv'.
-- Given a non-variadic constructor @C(x1:T1,..,xn:Tn)@,
-- a method name @method@, a type name @ty@ and a combinator @comb@,
-- @compEqAux method comb ty C@ generates
--
-- > public boolean method(ty o) {
-- > if (o instanceof C) {
-- > C typed_o = (C) o;
-- > return true &&
-- > this.x1 `comb` o.x1 &&
-- > ...
-- > this.xn `comb` o.xn;
-- > } else {
-- > return false;
-- > }
-- > }
compEqAux :: Doc -> (Doc -> Doc -> Doc) -> Doc -> CtorId -> Gen Doc
compEqAux meth comb ty c = do rcalls <- iterOverFields rcall id c
return $ rMethodDef
(public <+> final) jboolean meth
[ty <+> text "__o"] (complete rcalls)
where pc = pretty c
complete b = rIfThenElse cond (branch1 b) (jreturn <+> false <> semi)
cond = text "__o" <+> instanceof <+> pc
branch1 b = rBody [l1,l2 (true:b)]
l1 = pc <+> text "__typed_o" <+> equals <+> parens pc <+> text "__o"
l2 b = jreturn <+> (align . fillSep $ intersperse (text "&&") b)
rcall x s = let lhs = this <> dot <> _u (pretty x)
rhs = text "__typed_o." <> _u (pretty x)
in return $ if isBuiltin s
then lhs <+> text "==" <+> rhs
else lhs `comb` rhs
-- | Given a sort @s@, @randomRecCall s@ generates
--
-- * @mod.modAbstractType.randoms(rand)@ if @s@ is a builtin,
--
-- * @mod.types.s.makeRandom(rand,depth)@ otherwise
randomRecCall :: SortId -> Gen Doc
randomRecCall s = do
qs <- qualifiedSort s
at <- qualifiedAbstractType
return $ if isBuiltin s
then rMethodCall at (text "random" <> pretty s) [text "__rand"]
else rMethodCall qs (text "makeRandom") [text "__rand", text "__depth"]
-- | Given a constructor @C(x1:T1,...,xn:Tn)@,
-- of codomain @Co@, generates
--
-- > final static public
-- > mod.types.Co makeRandom(java.util.Random rand, int depth) {
-- > return
-- > mod.types.co.C.make(mod.types.T1.makeRandom(rand,depth),
-- > ...,
-- > mod.types.Tn.makeRandom(rand,depth));
-- > }
compMakeRandomConstructor :: CtorId -> Gen Doc
compMakeRandomConstructor c = do
qc <- qualifiedCtor c
co <- askSt (codomainOf c)
qco <- qualifiedSort co
tys <- map snd `fmap` askSt (fieldsOf c)
rcalls <- mapM randomRecCall tys
return $ rMethodDef (final <+> static <+> public)
qco (text "makeRandom")
[text "java.util.Random __rand", text "int __depth"]
(body qc rcalls)
where body qc rc = jreturn <+> rMethodCall qc (text "make") rc <> semi
-- | Given a constructor @C(x1:T1,...,xn:Tn)@, generates
--
-- > final public static int depth() {
-- > int max = 0;
-- > int cd = 0;
-- > cd = x1.depth();
-- > if (cd > max) max = cd;
-- > ...
-- > cd = xn.depth();
-- > if (cd > max) max = cd;
-- > return max + 1;
-- > }
compDepthConstructor :: CtorId -> Gen Doc
compDepthConstructor c = do
fis <- askSt (fieldsOf c)
return .wrap $ if null fis then text "return 0;" else pack fis
where call (f,s)
| isBuiltin s = []
| otherwise = [this <> dot <> _u (pretty f) <> text ".depth();",
text "if (__cd > __max) __max = __cd;"]
pack l = vcat ([pre] ++ mid ++ [post])
where pre = text "int __max = 0; int __cd = 0;"
mid = concatMap call l
post = text "return __max + 1;"
wrap d = text "final public int depth()" <+> ibraces d
-- > final public static int size() {
-- > return x1.size() + ... + xn.size();
-- > }
compSizeConstructor :: CtorId -> Gen Doc
compSizeConstructor c = do
fis <- askSt (fieldsOf c)
return . pack $ if null fis then one else add (map call fis)
where add = align . fillSep . intersperse (text "+")
one = text "1"
call (f,s) | isBuiltin s = one
| otherwise = this <> dot <> _u (pretty f)
<> text ".size()"
pack d = text "final public int size()"
<+> ibraces (jreturn <+> d <> semi)