hgom 0.5.3 → 0.6
raw patch · 13 files changed
+287/−71 lines, 13 filesbinary-added
Files
- CHANGELOG.markdown +10/−0
- Gom.hs +1/−1
- Gom/CodeGen/Common/Helpers.hs +33/−3
- Gom/CodeGen/Mappings.hs +40/−25
- Gom/CodeGen/Sorts.hs +1/−1
- Gom/CodeGen/Strategies.hs +188/−35
- Gom/Config.hs +2/−2
- Gom/UnitTests.hs +9/−2
- README.markdown +1/−1
- hgom.cabal +2/−1
- test/data/shared-objects.jar binary
- test/data/tom-runtime-full.jar too large to diff
- test/data/tom_runtime.jar binary
+ CHANGELOG.markdown view
@@ -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
Gom.hs view
@@ -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 ()
Gom/CodeGen/Common/Helpers.hs view
@@ -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
Gom/CodeGen/Mappings.hs view
@@ -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
Gom/CodeGen/Sorts.hs view
@@ -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]
Gom/CodeGen/Strategies.hs view
@@ -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> 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> T visitLight(T any,",- " tom.library.sl.Introspector introspector)", + ["public <T> 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> 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> 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)
Gom/Config.hs view
@@ -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)
Gom/UnitTests.hs view
@@ -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)
README.markdown view
@@ -109,7 +109,7 @@ ### Worse ### - * no hooks !+ * no hooks! * no ant task * imports only builtins * generates no comments
hgom.cabal view
@@ -1,5 +1,5 @@ name: hgom-version: 0.5.3+version: 0.6 author: Paul Brauner and Emilie Balland maintainer: Paul Brauner <paul.brauner@inria.fr> 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
binary file changed (absent → 25633 bytes)
− test/data/tom-runtime-full.jar
file too large to diff
+ test/data/tom_runtime.jar view
binary file changed (absent → 56322 bytes)