------------------------------------------------------------------ -- | -- 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)