diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,10 @@ +# hgom Changelog + +## version 0.6 + + - fixed critical bug (`par` instead of `__par`) + - added `Make_C` and `Is_C` classes generation + +## version 0.5.3 + + - first public release diff --git a/Gom.hs b/Gom.hs --- a/Gom.hs +++ b/Gom.hs @@ -36,7 +36,7 @@ #endif hgomVersion :: String -hgomVersion = "Version 0.5.3 - March 2009" +hgomVersion = "Version 0.6 - March 2009" -- | @main = getArgs >>= entryPoint@ main :: IO () diff --git a/Gom/CodeGen/Common/Helpers.hs b/Gom/CodeGen/Common/Helpers.hs --- a/Gom/CodeGen/Common/Helpers.hs +++ b/Gom/CodeGen/Common/Helpers.hs @@ -40,6 +40,8 @@ -- ** Mappings rOp, rOpList, rTypeterm, rIsFsym, rMake, rGetSlot, + rMakeStrat, rGetSlotStrat, + rWhenOp, -- ** Other inline ) where @@ -254,17 +256,45 @@ -> Doc rMake qc as = text "make" <> args <+> (sbraces . parens) (qc <> text ".make" <> iargs) - where gen = parens . hcat . punctuate comma - args = gen as - iargs = gen (map inline as) + where args = encloseCommasNB as + iargs = encloseCommasNB (map inline as) +-- | Renders @make(x1,..,xn) { new m.strategy.co._C($x1,..,$xn)@ +rMakeStrat + :: Int -- ^ the number of arguments + -> Doc -- ^ the qualified congruence strategy class + -> Doc +rMakeStrat n sc = + text "make" <> args n "x" <+> sbraces (new <+> sc <> args n "$x") + where args ar s = encloseCommasNB [text s <> int i | i <- [1..ar]] +-- | Renders @get_slot(fi,t) { (tom.library.sl.Strategy) $t.getChildAt(i) }@ +rGetSlotStrat + :: Doc -- ^ the field prefix (@f@ in @fi@) + -> Int -- ^ the field number + -> Doc +rGetSlotStrat f i = + text "get_slot(" <> f <> int i <> text ",t)" <+> + sbraces (parens jStrategy <+> text "$t.getChildAt" <> parens (int i)) + -- | Renders @get_slot(slot,t) { $t.getslot() }@. rGetSlot :: Doc -- ^ slot -> Doc rGetSlot x = text "get_slot(" <> x <> text ",t) { $t.get" <> x <> text "() }" + +-- | Renders +-- +-- > %op Strategy When_C(s:Strategy) { +-- > make(s) { `Sequence(Is_C(),s) } +-- > } +rWhenOp + :: Doc -- ^ constructor id (@C@ in the example) + -> Doc +rWhenOp c = rOp strat (text "When_" <> c) [(text "s",strat)] body + where strat = text "Strategy" + body = text "make(s) { `Sequence(Is_" <> c <> text "(),s) }" -- | Renders @%op sort c(field1,..,field2) { body }@. rOp :: Doc -- ^ sort diff --git a/Gom/CodeGen/Mappings.hs b/Gom/CodeGen/Mappings.hs --- a/Gom/CodeGen/Mappings.hs +++ b/Gom/CodeGen/Mappings.hs @@ -35,13 +35,17 @@ tyts <- mapM compTypeTerm srts ops <- mapM compOp ctrs opls <- mapM compOpList vctrs - sops <- mapM compSOp ctrs + let always = incls:(tyts++ops++opls) + cops <- mapM (compSOp empty) ctrs + mops <- mapM (compSOp $ text "Make") ctrs + iops <- mapM compIsOp ctrs + let wops = map (rWhenOp . pretty) ctrs + sops = cops++mops++iops++wops vcongr <- askConf congr - let mappings = incls:(tyts++ops++opls) return $ case vcongr of - NoCongr -> [Tom mn (vsep mappings)] - SameFile -> [Tom mn (vsep $ includeSl:mappings++sops)] - SeparateFile -> [Tom mn $ vsep mappings, + NoCongr -> [Tom mn (vsep always)] + SameFile -> [Tom mn (vsep $ includeSl:always++sops)] + SeparateFile -> [Tom mn $ vsep always, Tom ('_':mn) (vsep $ includeSl:sops)] -- | Generates @%include { x.tom }@ for every imported sort @x@ @@ -112,28 +116,39 @@ (pretty dom) consc emptyc -- | Given a non-variadic constructor @C(x1:T1,..,xn:Tn)@ --- of codomain @Co@, generates +-- of codomain @Co@, @compSOp prefix C@ generates -- --- > %op Strategy _C(s1:Strategy,..,sn:Strategy) { --- > is_fsym(t) { $t m.strategy.co._C } +-- > %op Strategy prefix_C(s1:Strategy,..,sn:Strategy) { +-- > is_fsym(t) { $t m.strategy.co.prefix_C } -- > get_slot(s1,t) { (tom.library.sl.Strategy) $t.getChildAt(0) } -- > ... -- > get_slot(sn,t) { (tom.library.sl.Strategy) $t.getChildAt(n-1) } --- > make (t1,..,tn) { new m.strategy.co._C($t1,..,$tn) } +-- > make (t1,..,tn) { new m.strategy.co.prefix_C($t1,..,$tn) } -- > } -compSOp :: CtorId -> Gen Doc -compSOp c = do sc <- compStratClass - n <- length `fmap` askSt (fieldsOf c) - return $ rOp (text "Strategy") (_u $ pretty c) (mkTypedArgs n) - (vcat [rIsFsym sc, slots n, mkMake n sc]) - where compStratClass = do co <- askSt (codomainOf c) - pr <- qualifiedStratPrefix co - return $ pr <> dot <> _u (pretty c) - mkSlot i = text "get_slot(s" <> int i <> - text ",t) { (tom.library.sl.Strategy) $t.getChildAt(" <> - int (i-1) <> text ") }" - mkMake n sc = text "make" <> args n "s" <> text "{ new " <> - sc <> args n "$s" <> text " }" - where args ar s = encloseCommasNB [text s <> int i | i <- [1..ar]] - mkTypedArgs n = [(text "s" <> int i, text "Strategy") | i <- [1..n]] - slots n = vcat $ map mkSlot [1..n] +compSOp :: Doc -> CtorId -> Gen Doc +compSOp pr c = do sc <- compStratClass + n <- length `fmap` askSt (fieldsOf c) + return $ rOp strat cln (rArgs n) + (vcat [rIsFsym sc, slots n, rMakeStrat n sc]) + where arg = text "s" + cln = pr <> _u (pretty c) + strat = text "Strategy" + rArgs n = [(arg <> int i, strat) | i <- [0..n-1]] + slots n = vcat $ map (rGetSlotStrat arg) [0..n-1] + compStratClass = do + spr <- qualifiedStratPrefix =<< askSt (codomainOf c) + return $ spr <> dot <> cln + +-- | Given a non-variadic constructor @C@, generates +-- +-- > %op Strategy Is_C() { +-- > make() { new m.strategy.co.Is_C()} +-- > } +compIsOp :: CtorId -> Gen Doc +compIsOp c = do + sc <- compStratClass + return $ rOp (text "Strategy") cln [] (rMakeStrat 0 sc) + where cln = text "Is_" <> pretty c + compStratClass = do + spr <- qualifiedStratPrefix =<< askSt (codomainOf c) + return $ spr <> dot <> cln diff --git a/Gom/CodeGen/Sorts.hs b/Gom/CodeGen/Sorts.hs --- a/Gom/CodeGen/Sorts.hs +++ b/Gom/CodeGen/Sorts.hs @@ -132,7 +132,7 @@ [pars pr <+> arg] (vcat [pre,calls]) where pars pr = pr <> dot <> text "Parser" arg = text "__par" - pre = text "String __id = par.parseId();" + pre = text "String __id = __par.parseId();" post = text "throw new RuntimeException();" cond c = rMethodCall (text "__id") (text "equals") [dquotes $ pretty c] rcall qc = rMethodCall (pretty qc) (text "parseArgs") [arg] diff --git a/Gom/CodeGen/Strategies.hs b/Gom/CodeGen/Strategies.hs --- a/Gom/CodeGen/Strategies.hs +++ b/Gom/CodeGen/Strategies.hs @@ -28,34 +28,80 @@ compStrategy :: SortId -> Gen FileHierarchy compStrategy s = do ctrs <- askSt (sCtorsOf s) cs <- mapM compCongruence ctrs - return $ Package (show $ lowerId s) cs + ms <- mapM compMake ctrs + is <- mapM compIs ctrs + return $ Package (show $ lowerId s) (cs++ms++is) -- | Given a non-variadic constructor @C@, --- generates a congruence strategy class @_C.java@. +-- generates a congruence strategy class @_C@. compCongruence :: CtorId -> Gen FileHierarchy compCongruence c = - do body <- vcat `fmap` sequence [compCongruenceConstructor c, - compVisit c, compVisitLight c] + do body <- vcat `fmap` sequence + [compStratConstructor (text "_") c, + compVisitCongr c, + compVisitLightCongr c] return $ Class classname (wrap body) where wrap = rClass public (text classname) (Just jSCombinator) [] classname = '_':show c +-- | Given a non-variadic constructor @C@, +-- generates the creation strategy class @Make_C@. +compMake :: CtorId -> Gen FileHierarchy +compMake c = do + body <- vcat `fmap` sequence + [compStratConstructor (text "Make_") c, + compVisitMake c, + compVisitLightMake c] + return $ Class classname (wrap body) + where wrap = rClass public (text classname) (Just jSCombinator) [] + classname = "Make_" ++ show c + +-- | Given a non-variadic constructor @C@, +-- generates the test strategy class @Is_C@. +compIs :: CtorId -> Gen FileHierarchy +compIs c = do + qc <- qualifiedCtor c + return $ Class classname (wrap $ body qc) + where wrap = rClass public (text classname) (Just jSCombinator) [] + classname = "Is_" ++ show c + body qc = vcat $ map text + ["private static final String msg = \"Not a " ++ show c ++"\";", + "public Is_" ++ show c ++ "() {", + " initSubterm();", + "}", + "public T visitLight(T __any, tom.library.sl.Introspector __i)", + " throws tom.library.sl.VisitFailure {", + " if(__any instanceof " ++ show qc ++ "){", + " return __any;", + " } else {", + " throw new tom.library.sl.VisitFailure(msg);", + " }", + "}", + "public int visit(tom.library.sl.Introspector __i) {", + " Object __any = environment.getSubject();", + " if(__any instanceof " ++ show qc ++ ") {", + " return tom.library.sl.Environment.SUCCESS;", + " } else {", + " return tom.library.sl.Environment.FAILURE;", + " }", + "}"] + -- | Given a non-variadic constructor @C@, generates -- the method @public int visit(Introspector introspector) { ... }@ -- for class @_C@. -compVisit :: CtorId -> Gen Doc -compVisit c = body `fmap` qualifiedCtor c +compVisitCongr :: CtorId -> Gen Doc +compVisitCongr c = body `fmap` qualifiedCtor c where body qc = vcat $ map text - ["public int visit(tom.library.sl.Introspector introspector) {", - " environment.setIntrospector(introspector);", - " Object any = environment.getSubject();", - " if (any instanceof " ++ show qc ++ ") {", - " int childCount = introspector.getChildCount(any);", + ["public int visit(tom.library.sl.Introspector __i) {", + " environment.setIntrospector(__i);", + " Object __any = environment.getSubject();", + " if (__any instanceof " ++ show qc ++ ") {", + " int childCount = __i.getChildCount(__any);", " Object[] childs = null;", " for(int i = 0; i < childCount; i++) {", - " Object oldChild = introspector.getChildAt(any,i);", + " Object oldChild = __i.getChildAt(__any,i);", " environment.down(i+1);", - " int status = arguments[i].visit(introspector);", + " int status = arguments[i].visit(__i);", " if(status != tom.library.sl.Environment.SUCCESS) {", " environment.upLocal();", " return status;", @@ -65,14 +111,14 @@ " childs[i] = newChild;", " } else if(newChild != oldChild) {", " // allocate the array, and fill it", - " childs = introspector.getChildren(any);", + " childs = __i.getChildren(__any);", " childs[i] = newChild;", " } ", " environment.upLocal();", " }", " if(childs!=null) {", " environment.setSubject", - " (introspector.setChildren(any,childs));", + " (__i.setChildren(__any,childs));", " }", " return tom.library.sl.Environment.SUCCESS;", " } else {", @@ -83,47 +129,154 @@ -- | Given a non-variadic constructor @C@, generates -- the method @public int visitLight(Introspector introspector) { ... }@ -- for class @_C@. -compVisitLight :: CtorId -> Gen Doc -compVisitLight c = do n <- length `fmap` askSt (fieldsOf c) - qc <- qualifiedCtor c - return $ body qc n +compVisitLightCongr :: CtorId -> Gen Doc +compVisitLightCongr c = do + n <- length `fmap` askSt (fieldsOf c) + qc <- qualifiedCtor c + return $ body qc n where body qc n = vcat $ map text - ["public T visitLight(T any,", - " tom.library.sl.Introspector introspector)", + ["public T visitLight(T __any,", + " tom.library.sl.Introspector __i)", " throws tom.library.sl.VisitFailure {", - " if(any instanceof " ++ show qc ++ ") {", - " T result = any;", + " if(__any instanceof " ++ show qc ++ ") {", + " T result = __any;", " Object[] childs = null;", - " for (int i = 0, nbi = 0; i <" ++ show n ++"; i++) {", - " Object oldChild = introspector.getChildAt(any,nbi);", + " for (int i = 0, nbi = 0; i < " ++ show n ++"; i++) {", + " Object oldChild = __i.getChildAt(__any,nbi);", " Object newChild =", - " arguments[i].visitLight(oldChild,introspector);", + " arguments[i].visitLight(oldChild,__i);", " if(childs != null) {", " childs[nbi] = newChild;", " } else if(newChild != oldChild) {", " // allocate the array, and fill it", - " childs = introspector.getChildren(any);", + " childs = __i.getChildren(__any);", " childs[nbi] = newChild;", " }", " nbi++;", " }", " if(childs!=null) {", - " result = introspector.setChildren(any,childs);", + " result = __i.setChildren(__any,childs);", " }", " return result;", " } else {", " throw new tom.library.sl.VisitFailure();", " }", "}"] - --- | Given a non-variadic constructor @C@, generates --- the constructor of @_C@. -compCongruenceConstructor :: CtorId -> Gen Doc -compCongruenceConstructor c = do + +-- | Given a non-variadic constructor @C(_:T0,...,_:Tn)@, generates +-- > public int visit(tom.library.Introspector i) { +-- > getChildAt(0).visit(i); +-- > if (! (getEnvironment().getSubject() instanceof m.types.T0)) { +-- > return tom.library.sl.Environment.FAILURE; +-- > } +-- > foo.types.T0 new_t0 = (foo.types.T0) getEnvironment().getSubject(); +-- > +-- > ... +-- > +-- > getChildAt(n).visit(i); +-- > if (! (getEnvironment().getSubject() instanceof m.types.Tn)) { +-- > return tom.library.sl.Environment.FAILURE; +-- > } +-- > foo.types.Tn new_tn = (foo.types.Tn) getEnvironment().getSubject(); +-- > +-- > getEnvironment().setSubject(m.types.co.C.make(new_t0, ..., new_tn)); +-- > return tom.library.sl.Environment.SUCCESS; +-- > } +compVisitMake :: CtorId -> Gen Doc +compVisitMake c = do + qc <- qualifiedCtor c + ss <- map snd `fmap` askSt (fieldsOf c) + qss <- mapM myQualifiedSort ss + let n = length qss + return . method . vcat $ + (zipWith block qss [0..]) ++ [setSub qc n, lastLine] + where myQualifiedSort s | isBuiltin s = return $ qualifiedBuiltin s + | otherwise = qualifiedSort s + -- getChildAt(n) [...] = (foo.types.Tn) getEnvironment().getSubject() + block qs i = vcat [getChild, testSort, assignTi] + where getChild = cast (text "getChildAt" <> parens (int i)) + <> text ".visit(__i);" + testSort = rIfThen cond failure + assignTi = qs <+> text "new_t" <> int i <+> equals <+> + parens qs <+> text "getEnvironment().getSubject();" + cond = text "!(getEnvironment().getSubject() instanceof " + <> qs <> text ")" + failure = text "return tom.library.sl.Environment.FAILURE;" + cast x = parens (parens jStrategy <+> x) + -- getEnvironment().setSubject(m.types.co.C.make(new_t0, ..., new_tn)) + setSub qc n = rMethodCall (text "getEnvironment()") (text "setSubject") + [rMethodCall qc (text "make") ts] <> semi + where ts = [text "new_t" <> int i | i <- [0..n-1]] + lastLine = text "return tom.library.sl.Environment.SUCCESS;" + method body = text "public int visit(tom.library.sl.Introspector __i)" + <+> ibraces body + +-- | Given a non-variadic constructor @C(_:T0,...,_:Tn)@, generates +-- > public T visitLight(T any, tom.library.Introspector i) +-- > throws tom.library.sl.VisitFailure { +-- > Object tmp_t0 = ((tom.library.sl.Strategy) getChildAt(0)).visit(any,i); +-- > if (!(tm_t0 instanceof m.types.T0)) { +-- > throw new tom.library.sl.VisitFailure(); +-- > } +-- > foo.types.T0 new_t0 = (foo.types.T0) tmp_t0; +-- > +-- > ... +-- > +-- > Object tmp_tn = ((tom.library.sl.Strategy) getChildAt(n)).visit(any,i); +-- > if (!(tm_tn instanceof m.types.Tn)) { +-- > throw new tom.library.sl.VisitFailure(); +-- > } +-- > foo.types.Tn new_tn = (foo.types.Tn) tmp_tn; +-- > +-- > return (T) m.types.co.C.make(new_t0, ..., new_tn); +-- > } +compVisitLightMake :: CtorId -> Gen Doc +compVisitLightMake c = do + qc <- qualifiedCtor c + ss <- map snd `fmap` askSt (fieldsOf c) + qss <- mapM myQualifiedSort ss + let n = length qss + return . method . vcat $ + (zipWith block qss [0..]) ++ [lastLine qc n] + where myQualifiedSort s | isBuiltin s = return $ qualifiedBuiltin s + | otherwise = qualifiedSort s + -- Object tmp_tn [...] = (foo.types.Tn) tmp_tn + block qs i = vcat [visitChild, testSort, assignTi] + where visitChild = text "Object" <+> tmp_i <+> equals <+> + cast (text "getChildAt" <> parens (int i)) + <> text ".visit(__any,__i);" + tmp_i = text "__tmp_" <> int i + testSort = rIfThen cond failure + assignTi = qs <+> text "__new_t" <> int i <+> equals + <+> parens qs <+> tmp_i <> semi + cond = text "!(" <> tmp_i <+> instanceof <+> qs <> text ")" + failure = text "throw new tom.library.sl.VisitFailure();" + cast x = parens (parens jStrategy <+> x) + -- return (T) m.types.co.C.make(new_t0, ..., new_tn); + lastLine qc n = text "return (T)" <+> + rMethodCall qc (text "make") ts <> semi + where ts = [text "__new_t" <> int i | i <- [0..n-1]] + method body = (vcat $ map text + ["public T visitLight(T __any,", + " tom.library.sl.Introspector __i)", + " throws tom.library.sl.VisitFailure"]) + <+> ibraces body + +-- | Given a non-variadic constructor @C(x1,...,xn)@ +-- and a prefix @prefix@, generates +-- +-- > public prefixf(tom.library.sl.Strategy s_x1, +-- > ..., +-- > tom.library.sl.Strategy s_xn) { +-- > this.initSubterm( +-- > new tom.library.sl.Strategy[] { s_x1, ..., s_xn }); +-- > } +compStratConstructor :: Doc -> CtorId -> Gen Doc +compStratConstructor pr c = do fs <- map convert `fmap` askSt (fieldsOf c) - return $ rMethodDef public empty (text "_" <> pretty c) + return $ rMethodDef public empty (pr <> pretty c) (map (jStrategy <+>) fs) (rBody [body fs]) - where convert = (text "s" <>) . pretty . fst + where convert = (text "__s_" <>) . pretty . fst body fs = rMethodCall this (text "initSubterm") [array] where array = new <+> jStrategyArray <+> sbraces content content = align $ sep (punctuate comma fs) diff --git a/Gom/Config.hs b/Gom/Config.hs --- a/Gom/Config.hs +++ b/Gom/Config.hs @@ -103,10 +103,10 @@ ,Option ['c'] ["congruence"] (ReqArg ccongr "(same|sep)") (unlines ["generate congruence strategies in", "the same or in a separate .tom file"]) - ,Option ['r'] ["random"] (NoArg crandom) - "generate makeRamdom methods" ,Option ['j'] ["oomappings"] (NoArg coomapping) "generate only Java OO mappings" + ,Option ['r'] ["random"] (NoArg crandom) + "generate makeRamdom methods" ,Option ['d'] ["depth"] (NoArg cdepth) "generate depth methods" ,Option ['s'] ["size"] (NoArg csize) diff --git a/Gom/UnitTests.hs b/Gom/UnitTests.hs --- a/Gom/UnitTests.hs +++ b/Gom/UnitTests.hs @@ -120,6 +120,13 @@ checks :: Module -> Bool checks = isNothing . checkEverything +-- | classpath needed for tests +dataClassPath :: IO String +dataClassPath = do + j1 <- getDataFileName $ "test" "data" "tom_runtime.jar" + j2 <- getDataFileName $ "test" "data" "shared-objects.jar" + return $ j1 ++ ":" ++ j2 ++ ":" + -- | test that the generated parser is correct w.r.t. -- the generated pretty printer (@fromString(x.toString()) == x@) propGenParsePretty :: Property @@ -132,7 +139,7 @@ writeFile "Test.gom" $ show sig _ <- rawSystem "hgom" ["-r","Test.gom"] writeFile "Test.java" $ template pack (show s) - cp <- getDataFileName $ "test" "data" "tom-runtime-full.jar:" + cp <- dataClassPath (st,_,_) <- readProcessWithExitCode "javac" ["-cp",cp,"Test.java"] "" let res = (st == ExitSuccess) return res) @@ -163,7 +170,7 @@ writeFile "Test.gom" $ show sig _ <- rawSystem "hgom" ("Test.gom":opts) jfs <- globDir1 (compile $ "**" "*.java") pack - cp <- getDataFileName $ "test" "data" "tom-runtime-full.jar:" + cp <- dataClassPath (st,_,_) <- readProcessWithExitCode "javac" (["-cp",cp]++jfs) "" let res = (st == ExitSuccess) return res) diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -109,7 +109,7 @@ ### Worse ### - * no hooks ! + * no hooks! * no ant task * imports only builtins * generates no comments diff --git a/hgom.cabal b/hgom.cabal --- a/hgom.cabal +++ b/hgom.cabal @@ -1,5 +1,5 @@ name: hgom -version: 0.5.3 +version: 0.6 author: Paul Brauner and Emilie Balland maintainer: Paul Brauner copyright: (c) Paul Brauner 2009 @@ -24,6 +24,7 @@ test/bench/Gen.hs test/bench/Makefile README.markdown + CHANGELOG.markdown data-files: test/data/*.gom test/data/*.jar diff --git a/test/data/shared-objects.jar b/test/data/shared-objects.jar new file mode 100644 Binary files /dev/null and b/test/data/shared-objects.jar differ diff --git a/test/data/tom-runtime-full.jar b/test/data/tom-runtime-full.jar deleted file mode 100644 # file too large to diff: test/data/tom-runtime-full.jar diff --git a/test/data/tom_runtime.jar b/test/data/tom_runtime.jar new file mode 100644 Binary files /dev/null and b/test/data/tom_runtime.jar differ