diff options
40 files changed, 1757 insertions, 1490 deletions
diff --git a/documentation/research/Memory Management.md b/documentation/research/Memory Management.md new file mode 100644 index 000000000..80f80ce12 --- /dev/null +++ b/documentation/research/Memory Management.md @@ -0,0 +1,4 @@ +# Reference counting + +1. [Counting Immutable Beans: Reference Counting Optimized for Purely Functional Programming](https://arxiv.org/abs/1908.05647) + diff --git a/documentation/research/Type theory/Dependent types.md b/documentation/research/Type theory/Dependent types.md index f8849fcd1..8ea68473b 100644 --- a/documentation/research/Type theory/Dependent types.md +++ b/documentation/research/Type theory/Dependent types.md @@ -1,9 +1,13 @@ # Exemplar +1. [A simple type-theoretic language: Mini-TT](http://www.cse.chalmers.se/~bengt/papers/GKminiTT.pdf) 1. https://cedille.github.io/ # Reference +1. [A Path To DOT: Formalizing Fully Path-Dependent Types](https://arxiv.org/abs/1904.07298) +1. [Ghosts of Departed Proofs (Functional Pearl)](https://www.youtube.com/watch?v=2cAxOJEiL00) +1. [Ghosts of Departed Proofs (Functional Pearl)](https://kataskeue.com/gdp.pdf) 1. [F# Linear algebra with type-level dimensions and static checks](https://notebooks.azure.com/allisterb/projects/sylvester/html/Sylvester.Tensors.ipynb) 1. [From Scheme to Dependent Types in 100 lines by Gershom Bazerman](https://vimeo.com/134561872 &&& https://vimeo.com/135746080) 1. [A Tutorial Implementation of a Dependently Typed Lambda Calculus](https://www.andres-loeh.de/LambdaPi/) diff --git a/documentation/research/distributed_programming.md b/documentation/research/distributed_programming.md index 991edf8b0..17f48122c 100644 --- a/documentation/research/distributed_programming.md +++ b/documentation/research/distributed_programming.md @@ -67,6 +67,7 @@ # Logical clock +1. [Version Vectors are not Vector Clocks](https://haslab.wordpress.com/2011/07/08/version-vectors-are-not-vector-clocks/) 1. [Distributed Systems: Physical, Logical, and Vector Clocks](https://levelup.gitconnected.com/distributed-systems-physical-logical-and-vector-clocks-7ca989f5f780) 1. [The Bloom Clock](https://arxiv.org/pdf/1905.13064.pdf) 1. [Why Logical Clocks are Easy: Sometimes all you need is the right language.](https://queue.acm.org/detail.cfm?id=2917756) diff --git a/documentation/research/game_programming.md b/documentation/research/game_programming.md index 5034eda93..30fa24165 100644 --- a/documentation/research/game_programming.md +++ b/documentation/research/game_programming.md @@ -1,3 +1,12 @@ +# Noise + +1. [Perlin noise](https://en.wikipedia.org/wiki/Perlin_noise) +1. [Gradient noise](https://en.wikipedia.org/wiki/Gradient_noise) +1. [Value noise](https://en.wikipedia.org/wiki/Value_noise) +1. [Simplex noise](https://en.wikipedia.org/wiki/Simplex_noise) +1. [OpenSimplex noise](https://en.wikipedia.org/wiki/OpenSimplex_noise) +1. [Worley noise](https://en.wikipedia.org/wiki/Worley_noise) + # Ethics 1. [Ethics in Game Design - PAX Prime 2012](https://www.youtube.com/watch?v=sIS5cJzeLGA) @@ -59,6 +68,9 @@ # Rendering +1. [The Graphics Codex](http://graphicscodex.com/) +1. [PIXELARTOR: Animation Tool for converting 3D models with animations to 2D sprite frames](https://github.com/Chleba/PIXELARTOR) +1. https://raytracing.github.io/ 1. [WebGL2 Fundamentals](https://webgl2fundamentals.org/) 1. [Tiles to Curves: Fun With Voronoi Graphs (part 1)](https://www.gamedev.net/articles/programming/general-and-gameplay-programming/tiles-to-curves-fun-with-voronoi-graphs-part-1-r5150/) 1. [Lazy Incremental Computation for Efficient Scene Graph Rendering](https://www.cg.tuwien.ac.at/courses/RendEng/2015/RendEng-2015-11-16-paper2.pdf) @@ -124,6 +136,7 @@ # Entity Component System (ECS) +1. [On DOTS: Entity Component System](https://blogs.unity3d.com/2019/03/08/on-dots-entity-component-system/) 1. http://cowboyprogramming.com/2007/01/05/evolve-your-heirachy/ 1. [Bob Nystrom - Is There More to Game Architecture than ECS?](https://www.youtube.com/watch?v=JxI3Eu5DPwE) @@ -168,6 +181,7 @@ # Hexagonal grid 1. https://www.redblobgames.com/grids/hexagons/ +1. [Hex Grid Geometry for Game Developers (1.3)](http://www.gamelogic.co.za/downloads/HexMath2.pdf) # Mods / Modding @@ -185,6 +199,138 @@ # Design +1. [WIRED by Design: A Game Designer Explains the Counterintuitive Secret to Fun](https://www.youtube.com/watch?v=78rPt0RsosQ) +1. [How to Add Literally Infinite Features into Minecraft (with one update)](https://www.youtube.com/watch?v=CS5DQVSp058) +1. [Can We Make Talking as Much Fun as Shooting? | Game Maker's Toolkit](https://www.youtube.com/watch?v=l9TzqNQBmr0) +1. [Are Score Systems Still Relevant? | Game Maker's Toolkit](https://www.youtube.com/watch?v=K6y9PJipfpk) +1. [What Makes a Good Combat System? | Game Maker's Toolkit](https://www.youtube.com/watch?v=8X4fx-YncqA) +1. [The Rise of the Systemic Game | Game Maker's Toolkit](https://www.youtube.com/watch?v=SnpAAX9CkIc) +1. [Playing Past Your Mistakes | Game Maker's Toolkit](https://www.youtube.com/watch?v=Go0BQugwGgM) +1. [How to Keep Players Engaged (Without Being Evil) | Game Maker's Toolkit](https://www.youtube.com/watch?v=hbzGO_Qonu0) +1. [Building Better Skill Trees | Game Maker's Toolkit](https://www.youtube.com/watch?v=wsmEuHa1eL8) +1. [The Year Stealth Games Got Serious | Game Maker's Toolkit](https://www.youtube.com/watch?v=Iz-XTR3pwrE) +1. [Why Synergies are the Secret to Slay the Spire’s Fun | Game Maker’s Toolkit](https://www.youtube.com/watch?v=terD4Bk3L_8) +1. [Why Metro Exodus is 2019’s Most Immersive Open World Game | Game Maker's Toolkit](https://www.youtube.com/watch?v=8geGHbWIMXA) +1. [Roguelikes, Persistency, and Progression | Game Maker's Toolkit](https://www.youtube.com/watch?v=G9FB5R4wVno) +1. [Do We Need a Soulslike Genre? | Game Maker's Toolkit](https://www.youtube.com/watch?v=Lx7BWayWu08) +1. [The Lost Soul Arts of Demon's Souls](https://www.youtube.com/watch?v=Np5PdpsfINA) +1. [Dark Souls 2 Critique](https://www.youtube.com/watch?v=UScsme8didI) +1. [The World Design of Castlevania: Symphony of the Night | Boss Keys](https://www.youtube.com/watch?v=a1hHOVIkrcc) +1. [Forging God of War's Leviathan Axe | Game Maker's Toolkit](https://www.youtube.com/watch?v=vwbz9gxoQFg) +1. [How Thief's Stealth System Almost Didn't Work | War Stories | Ars Technica](https://www.youtube.com/watch?v=qzD9ldLoc3c) +1. [What Makes a Good Puzzle? | Game Maker's Toolkit](https://www.youtube.com/watch?v=zsjC6fa_YBg) +1. [How Games Use Feedback Loops | Game Maker’s Toolkit](https://www.youtube.com/watch?v=H4kbJObhcHw) +1. [Three Other Approaches to Turn Timers | GMTK Extra](https://www.youtube.com/watch?v=QAVf7rb0IwM) +1. [The World Design of Dark Souls | Boss Keys](https://www.youtube.com/watch?v=QhWdBhc3Wjc) +1. [Depth, Mastery, and Vanquish | Game Maker's Toolkit](https://www.youtube.com/watch?v=IG8LVpuzYls) +1. [Morality in the Mechanics | Game Maker's Toolkit](https://www.youtube.com/watch?v=6RHH7M4siPM) +1. [Anatomy of a Side Quest: Beyond the Beef | Game Maker's Toolkit](https://www.youtube.com/watch?v=yM1yR7WYqgM) +1. [Telling Stories with Systems | Game Maker's Toolkit](https://www.youtube.com/watch?v=NyMndWpihTM) +1. [What Makes Good AI? | Game Maker's Toolkit](https://www.youtube.com/watch?v=9bbhJi0NBkk) +1. [What Makes a Good Detective Game? | Game Maker's Toolkit](https://www.youtube.com/watch?v=gwV_mA2cv_0) +1. [How Game Designers Protect Players From Themselves | Game Maker's Toolkit](https://www.youtube.com/watch?v=7L8vAGGitr8) +1. [What Made Psychonauts Special | Game Maker's Toolkit](https://www.youtube.com/watch?v=5I4vD2S01d0) +1. [How Event[0] Works | Game Maker's Toolkit](https://www.youtube.com/watch?v=bCJw4hQkPj4) +1. [The Comeback of the Immersive Sim | Game Maker's Toolkit](https://www.youtube.com/watch?v=kbyTOAlhRHk) +1. [How Games Do Health | Game Maker's Toolkit](https://www.youtube.com/watch?v=4AEKbBF3URE) +1. [Should Dark Souls Have an Easy Mode? | Game Maker's Toolkit](https://www.youtube.com/watch?v=K5tPJDZv_VE) +1. [Is Extreme RNG Bad For Game Design? (Critical Thought)](https://www.youtube.com/watch?v=yVhQWkQoykQ) +1. [What Does it Mean to Last in the Game Industry? | Critical Thought](https://www.youtube.com/watch?v=Xku4IOO37s0) +1. [The Game Design Trap of a Zelda Roguelike](https://www.youtube.com/watch?v=oWSj8WEy9YE) +1. [Using Supplemental Content to Grow Rogue-Like and Strategy Game Design -- Critical Thought](https://www.youtube.com/watch?v=xsbPr0SND5s) +1. [A Critical Thought on Class Based RPG Design](https://www.youtube.com/watch?v=EcX3rPHmmfI) +1. [Why 2D Game Design Is Never Going Away | Critical Thought](https://www.youtube.com/watch?v=CqO4DgJZC04) +1. [A Critical Thought on RPG Class Design](https://www.youtube.com/watch?v=ykvwgSAwvgM) +1. [The Difficulty Behind Grand Strategy Game Design -- Critical Thought](https://www.youtube.com/watch?v=Vthi6_fgkWk) +1. [Is The Swindle the First Great Heist Game? | Game Maker's Toolkit](https://www.youtube.com/watch?v=cUbyNJKsi7E) +1. [Redesigning Death | Game Maker's Toolkit](https://www.youtube.com/watch?v=6WyalnKQIpg) +1. [Secrets of Game Feel and Juice | Game Maker's Toolkit](https://www.youtube.com/watch?v=216_5nu4aVQ) +1. [The Game Design Trap of Modern Retro Games -- Critical Thought](https://www.youtube.com/watch?v=utfM4OVAlXw) +1. [The Secret to Replayable Video Games: Defining Variance (Critical Thought)](https://www.youtube.com/watch?v=6jmhzfk7cI0) +1. [The Limits of Battle Royale Game Design | Critical Thought](https://www.youtube.com/watch?v=jGEokQBbZm8) +1. [A Critical Thought on WRPG vs JRPG Design](https://www.youtube.com/watch?v=QptfFveZH40) +1. [When Does a Video Game Become Tactical? (Critical Thought)](https://www.youtube.com/watch?v=9DjMyJ4c6sc) +1. [How Numbers Impact Game Design (Critical Thought)](https://www.youtube.com/watch?v=ychRUeGxuA4) +1. [A Critical Thought on Asymmetrical Design and Balance](https://www.youtube.com/watch?v=ah-q6gmcCcM) +1. [A Critical Thought on RPG Progression](https://www.youtube.com/watch?v=kou6zzE7odk) +1. [A Critical Thought on Gear-Based Progression](https://www.youtube.com/watch?v=Qtf4JrJADuE) +1. [The Difference Between Environmental and Level Design in Video Games -- Critical Thought](https://www.youtube.com/watch?v=Lmf1oQIwNCk) +1. [The Limitations of Leveling in Game Design | Critical Thought](https://www.youtube.com/watch?v=V4EK53qA2ZA) +1. [What Makes Grinding Fun in Videogames | Critical Thought](https://www.youtube.com/watch?v=a5skg3YF6D0) +1. [Should Videogames be a Mystery? | Critical Thought](https://www.youtube.com/watch?v=J3Pm61xk444) +1. [A Critical Thought on Apex Predator Stealth Game Design](https://www.youtube.com/watch?v=69rJy146F7I) +1. [The Limits of Realism in Video Games -- Critical Thought](https://www.youtube.com/watch?v=R_hXwd-TXqw) +1. [What Makes an Immersive Sim? (Critical Thought)](https://www.youtube.com/watch?v=lMi1PNiQoTg) +1. [A Critical Thought on the Bar of Game Design](https://www.youtube.com/watch?v=30xMJFRNwpc) +1. [A Critical Thought on Persistent Systems in Game Design](https://www.youtube.com/watch?v=uk_1VoMtmK8) +1. [A Critical Thought on Game Pricing](https://www.youtube.com/watch?v=BGAa11Wmnsw) +1. [A Critical Thought on 7-9 Review Scores](https://www.youtube.com/watch?v=QjI_ayarAq4) +1. [A Critical Thought on Event-Driven Game Design](https://www.youtube.com/watch?v=df_cS3N5Ri4) +1. [A Critical Thought on the Flow State and Video Games](https://www.youtube.com/watch?v=dGfuN7PT8Fg) +1. [A Critical Thought on Boss Battle Design](https://www.youtube.com/watch?v=R73FdiuwNQc) +1. [The Difference Between Graphics and Aesthetics in Videogames (Critical Thought)](https://www.youtube.com/watch?v=dDh_P0FZYCE) +1. [A Critical Thought on the Foundation of Emergent Gameplay](https://www.youtube.com/watch?v=EbYvxZcMzGw) +1. [A Critical Thought on Environmental Storytelling in Video Games](https://www.youtube.com/watch?v=bryR9RY7KFs) +1. [A Critical Thought on Puzzle Design](https://www.youtube.com/watch?v=jlPokDZWN3Q) +1. [A Critical Thought on Good Stealth Game Design](https://www.youtube.com/watch?v=MMhR5o2EcLc) +1. [How to Define Gameplay in Videogames | Critical Thought](https://www.youtube.com/watch?v=S97Z8WarJT4) +1. [A Critical Thought on "Upen" World Game Design](https://www.youtube.com/watch?v=d0aced1ONCM) +1. [A Critical Thought on the Hierarchy of Fail States](https://www.youtube.com/watch?v=FACTASJ5UzA) +1. [The Problems With Designing for Depth in Videogames (Critical Thought)](https://www.youtube.com/watch?v=a9tbDWdZ7W0) +1. [The Contradiction of Fun Pain in Video Games -- Critical Thought](https://www.youtube.com/watch?v=SYaEAOlbCwE) +1. [A Critical Thought on Creating Enemy Behaviors in Game Design](https://www.youtube.com/watch?v=FoG_8wVdoow) +1. [A Critical Thought on Balancing Failure in Game Design](https://www.youtube.com/watch?v=DZW9f48G2mQ) +1. [How Dissonance Can Affect Videogames | Critical Thought](https://www.youtube.com/watch?v=Ip12_GQ09Bk) +1. [Defining the Core Gameplay Loop of your Game | Critical Thought](https://www.youtube.com/watch?v=-kIwf-dNXr0) +1. [Helpful Tips to Improve Playability in Game Design | Critical Thought](https://www.youtube.com/watch?v=pNsIe6EU4Cc) +1. [A Critical Thought on Understanding Emergent Gameplay](https://www.youtube.com/watch?v=LTc_zIsUfMw) +1. [Defining Accessibility vs. Playability in Game Design | Critical Thought](https://www.youtube.com/watch?v=ASwCEelR_J8) +1. [How to Fix Loot Boxes Before They're Banned | Critical Thought](https://www.youtube.com/watch?v=cPoaRpDRZbc) +1. [The Design Behind Effective Loot Tables -- Critical Thought](https://www.youtube.com/watch?v=Nz3dk3Q4LxY) +1. [A Critical Thought on When Video Game Difficulty Becomes Cheap](https://www.youtube.com/watch?v=fae9Q173YUU) +1. [A Critical Thought on Fair Use and Fan Games](https://www.youtube.com/watch?v=cTUW6-P_3Rg) +1. [A Critical Thought on Direct vs. Indirect Competition](https://www.youtube.com/watch?v=_Klc69XDR1w) +1. [A Critical Thought on Conditioning Players](https://www.youtube.com/watch?v=efeqryVz7ro) +1. [Sanderson's Laws of Magic](https://stormlightarchive.fandom.com/wiki/Sanderson%27s_Laws_of_Magic) +1. [A Critical Thought on Combining RPG and Action Games](https://www.youtube.com/watch?v=Kh8itq2jf_M) +1. [The Three Elements of Good Level Design in Video Games -- Critical Thought](https://www.youtube.com/watch?v=sHKc_DqdxQk) +1. [The Three Forms of Stealth Gameplay (Critical Thought)](https://www.youtube.com/watch?v=nLOMq5qCxKU) +1. [The Deeper Design Behind the Dark Souls Formula -- Critical Thought](https://www.youtube.com/watch?v=hlccvyRGdPI) +1. [The Limits of Randomization in Game Design -- Critical Thought](https://www.youtube.com/watch?v=fuIihMRNEeE) +1. [How RNG in Games is Like a Spice -- Critical Thought](https://www.youtube.com/watch?v=A3cG4IHaOUY) +1. [The Failing Point of Free to Play Game Design -- Critical Thought](https://www.youtube.com/watch?v=_7-cQdFgD4k) +1. [A Critical Thought on Game Design Abstraction](https://www.youtube.com/watch?v=odCFa72nQCc) +1. [A Critical Thought on Difficulty Scaling in Game Design](https://www.youtube.com/watch?v=Y4AQPefZwt0) +1. [What Makes the Collectible Hunt So Addicting in Videogames | Critical Thought](https://www.youtube.com/watch?v=mg-OlFeU0YQ) +1. [What Makes a Metroidvania Work? | Critical Thought](https://www.youtube.com/watch?v=4ggILevH7Tw) +1. [A Critical Thought on the Worst Kind of Video Game Grinding](https://www.youtube.com/watch?v=7jrYVFsW_Rw) +1. [A Critical Thought on Mixed Genre Game Design](https://www.youtube.com/watch?v=g7_nVpGVuHQ) +1. [The Problems With Punishment Systems in Videogames | Critical Thought](https://www.youtube.com/watch?v=gkp2tW_rzz0) +1. [Can Persistence Work in Esports? (Critical Thought)](https://www.youtube.com/watch?v=4BysWm6SqTk) +1. [A Critical Thought on The Race to the Bottom](https://www.youtube.com/watch?v=YhdbYhoWECs) +1. [A Critical Thought on Why Build Orders Spell Trouble for Video Games](https://www.youtube.com/watch?v=XJHxfnWUdTc) +1. [A Critical Thought on Persistence Mechanics](https://www.youtube.com/watch?v=G2W7JGB8uug) +1. [A Critical Thought on Regenerating Health Game Design](https://www.youtube.com/watch?v=tPlPxGAskx8) +1. [A Critical Thought on Meta-Game Design](https://www.youtube.com/watch?v=pjpf7wFnvaU) +1. [A Critical Thought on Hard Games](https://www.youtube.com/watch?v=z92x3tnXG2A) +1. [A Critical Thought on Downtime in Video Games](https://www.youtube.com/watch?v=t46bDmK4qFo) +1. [A Critical Thought on Item Hoarding](https://www.youtube.com/watch?v=hMybxTFMMXw) +1. [Why Morality Systems in Games Don't Work -- Critical Thought](https://www.youtube.com/watch?v=qvNMXZFc8og) +1. [A Critical Thought on ELO Rating Systems](https://www.youtube.com/watch?v=1akzEbNLKqs) +1. [A Critical Thought on Probability in Game Design](https://www.youtube.com/watch?v=wgi-MH1PxAg) +1. [Defining (And Reducing) Grinding in Video Games -- Critical Thought](https://www.youtube.com/watch?v=dPH2OkVJmnM) +1. [Explaining the Assassin's Creed Odyssey Backlash on Player Choice-- Critical Thought](https://www.youtube.com/watch?v=sJhPYiNopKo) +1. [Arkham Knight and the Scourge of Scale | Game Maker's Toolkit](https://www.youtube.com/watch?v=Kvbnc-7Y0fE) +1. [A Critical Thought on WRPG vs CRPG Design](https://www.youtube.com/watch?v=mzsRs-qinJU) +1. [A Critical Thought on Unpredictable Competitive Games](https://www.youtube.com/watch?v=LyrFdFwCYxw) +1. [A Critical Thought on Game Reviewers](https://www.youtube.com/watch?v=ejLcJ680Je0) +1. [A Critical Thought on Disgaea's Design and Layered Game Systems](https://www.youtube.com/watch?v=s_z5liQ4Zbw) +1. [A Critical Thought on the Dangers of Feature Creep](https://www.youtube.com/watch?v=3lvkxfOrnSo) +1. [A Critical Thought on Making Competitive Games](https://www.youtube.com/watch?v=su0zUE_iU14) +1. [A Critical Thought on Power Curves in Game Design](https://www.youtube.com/watch?v=j0-Mmcfq3so) +1. [A Critical Thought on the Blue Shell Debate](https://www.youtube.com/watch?v=teYuozYi8Kg) +1. [A Critical Thought on Strategy Guides](https://www.youtube.com/watch?v=vW3qgpt4s2c) +1. [A Critical Thought on Breaking Games](https://www.youtube.com/watch?v=aorjSqZMb5E) 1. [Level Design Patterns in 2D Games](http://akhalifa.com/documents/level-design-patterns.pdf) 1. https://en.wikipedia.org/wiki/Rules_of_Play diff --git a/documentation/research/machine_learning.md b/documentation/research/machine_learning.md index ca4780853..eac777566 100644 --- a/documentation/research/machine_learning.md +++ b/documentation/research/machine_learning.md @@ -1,3 +1,7 @@ +# Transformer + +1. [Transformers from scratch](http://www.peterbloem.nl/blog/transformers) + # Exemplar 1. https://ml5js.org/ diff --git a/documentation/research/math.md b/documentation/research/math.md index 6e72785c7..d271bb0f6 100644 --- a/documentation/research/math.md +++ b/documentation/research/math.md @@ -69,6 +69,7 @@ # Bézier curves +1. [Circles and lines vs. polynomial splines](https://wordsandbuttons.online/circles_and_lines_vs_polynomial_splines.html) 1. https://cormullion.github.io/blog/2018/06/21/bezier.html 1. https://pomax.github.io/bezierinfo/ 1. https://99designs.com/blog/engineering/math-draw-vector-curves/ @@ -138,6 +139,8 @@ # Geometric Algebra | Clifford Algebra +1. [Geometric Algebra for Computer Graphics](https://slides.com/enkimute/siggraph/#/) +1. https://bivector.net/ 1. https://slehar.wordpress.com/2014/03/18/clifford-algebra-a-visual-introduction/ 1. [Vectors and Beyond: Geometric Algebra and its Philosophical Significance](http://www.tara.tcd.ie/bitstream/handle/2262/61825/Vectors%20and%20Beyond%20as%20Printed.pdf?sequence=1&isAllowed=y) 1. [Let's remove Quaternions from every 3D Engine](http://marctenbosch.com/quaternions/) @@ -255,6 +258,7 @@ # Vector +1. [A Student's Guide to Vectors and Tensors (Student's Guides)](https://www.amazon.com/Students-Guide-Vectors-Tensors-Guides/dp/0521171903) 1. https://www.researchgate.net/publication/327989714_Coordinate_Free_Vector_Algebra_in_R2 # Knot theory diff --git a/documentation/research/operating_system.md b/documentation/research/operating_system.md index 2e26a3976..bd0c59f73 100644 --- a/documentation/research/operating_system.md +++ b/documentation/research/operating_system.md @@ -157,6 +157,7 @@ # Shell +1. [Magritte: A Language for Pipe-Based Programming](http://files.jneen.net/academic/thesis.pdf) 1. https://latacora.singles/2018/06/21/loud-subshells.html 1. https://github.com/ipetkov/conch-runtime 1. https://www.spinellis.gr/sw/dgsh/ diff --git a/documentation/research/paradigm/Ambient-Oriented Programming.md b/documentation/research/paradigm/Ambient-Oriented Programming.md new file mode 100644 index 000000000..4ff41ff5e --- /dev/null +++ b/documentation/research/paradigm/Ambient-Oriented Programming.md @@ -0,0 +1,5 @@ +# Reference + +1. [Ambient-Oriented Programming in AmbientTalk](http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.417.906&rep=rep1&type=pdf) +1. [Ambient-oriented programming](https://dl.acm.org/citation.cfm?id=1094867) +1. [AmbientTalk](https://en.wikipedia.org/wiki/AmbientTalk) diff --git a/documentation/research/paradigm/logic_programming.md b/documentation/research/paradigm/logic_programming.md index 6e1c604cf..25c059ca9 100644 --- a/documentation/research/paradigm/logic_programming.md +++ b/documentation/research/paradigm/logic_programming.md @@ -29,6 +29,7 @@ # Language +1. [Curry: A Truly Integrated Functional Logic Language](https://www-ps.informatik.uni-kiel.de/currywiki/) 1. https://flix.github.io/ 1. http://logtalk.org/ 1. https://github.com/fnogatz/CHR.js diff --git a/documentation/research/tool/build_system.md b/documentation/research/tool/build_system.md index d52222929..24fa96627 100644 --- a/documentation/research/tool/build_system.md +++ b/documentation/research/tool/build_system.md @@ -1,5 +1,6 @@ # Exemplar +1. [Pier: Yet another Haskell build tool](https://www.youtube.com/watch?v=JmenfeDVi0w) 1. https://buckbuild.com/ 1. http://boot-clj.com/ 1. http://gulpjs.com/ diff --git a/new-luxc/source/luxc/lang/host/jvm.lux b/new-luxc/source/luxc/lang/host/jvm.lux index 7216a1708..d3ead1095 100644 --- a/new-luxc/source/luxc/lang/host/jvm.lux +++ b/new-luxc/source/luxc/lang/host/jvm.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- Definition) + [lux (#- Definition Type) [host (#+ import:)] [abstract monad] @@ -15,7 +15,8 @@ [syntax (#+ syntax:)]] [target [jvm - [type (#+ Class)]]] + ["." type (#+ Type) + [category (#+ Class)]]]] [tool [compiler [reference (#+ Register)] @@ -119,5 +120,5 @@ (org/objectweb/asm/Label::new))) (def: #export (simple-class name) - (-> Text Class) - [name (list)]) + (-> Text (Type Class)) + (type.class name (list))) diff --git a/new-luxc/source/luxc/lang/host/jvm/def.lux b/new-luxc/source/luxc/lang/host/jvm/def.lux index b663b9b31..08fccc640 100644 --- a/new-luxc/source/luxc/lang/host/jvm/def.lux +++ b/new-luxc/source/luxc/lang/host/jvm/def.lux @@ -11,16 +11,21 @@ ["%" format (#+ format)]] [collection ["." array (#+ Array)] - ["." list ("#/." functor)]]] + ["." list ("#@." functor)]]] [target [jvm [encoding ["." name]] - ["$t" type (#+ Method Class Type Parameter) - ["." reflection] + ["." type (#+ Type Constraint) + [category (#+ Class Value Method)] + ["." signature (#+ Signature)] ["." descriptor (#+ Descriptor)]]]]] ["." //]) +(def: signature (|>> type.signature signature.signature)) +(def: descriptor (|>> type.descriptor descriptor.descriptor)) +(def: class-name (|>> type.descriptor descriptor.class-name name.read)) + (import: #long java/lang/Object) (import: #long java/lang/String) @@ -72,7 +77,7 @@ (def: (string-array values) (-> (List Text) (Array Text)) (let [output (host.array String (list.size values))] - (exec (list/map (function (_ [idx value]) + (exec (list@map (function (_ [idx value]) (host.array-write idx value output)) (list.enumerate values)) output))) @@ -118,36 +123,32 @@ (if (get@ #//.transientF config) (Opcodes::ACC_TRANSIENT) +0) (if (get@ #//.volatileF config) (Opcodes::ACC_VOLATILE) +0))) -(def: class-to-type - (-> Class Type) - (|>> #$t.Class #$t.Generic)) - (def: param-signature - (-> Class Text) - (|>> class-to-type $t.signature (format ":"))) + (-> (Type Class) Text) + (|>> ..signature (format ":"))) (def: (formal-param [name super interfaces]) - (-> Parameter Text) + (-> Constraint Text) (format name (param-signature super) (|> interfaces - (list/map param-signature) + (list@map param-signature) (text.join-with "")))) -(def: (parameters-signature parameters super interfaces) - (-> (List Parameter) Class (List Class) +(def: (constraints-signature constraints super interfaces) + (-> (List Constraint) (Type Class) (List (Type Class)) Text) - (let [formal-params (if (list.empty? parameters) + (let [formal-params (if (list.empty? constraints) "" (format "<" - (|> parameters - (list/map formal-param) + (|> constraints + (list@map formal-param) (text.join-with "")) ">"))] (format formal-params - (|> super class-to-type $t.signature) + (..signature super) (|> interfaces - (list/map (|>> class-to-type $t.signature)) + (list@map ..signature) (text.join-with ""))))) (def: class-computes @@ -160,9 +161,9 @@ (def: binary-name (|>> name.internal name.read)) (template [<name> <flag>] - [(def: #export (<name> version visibility config name parameters super interfaces + [(def: #export (<name> version visibility config name constraints super interfaces definitions) - (-> //.Version //.Visibility //.Class-Config Text (List Parameter) Class (List Class) //.Def + (-> //.Version //.Visibility //.Class-Config Text (List Constraint) (Type Class) (List (Type Class)) //.Def (host.type [byte])) (let [writer (|> (do-to (ClassWriter::new class-computes) (ClassWriter::visit (version-flag version) @@ -172,10 +173,10 @@ (visibility-flag visibility) (class-flags config)) (..binary-name name) - (parameters-signature parameters super interfaces) - (|> super product.left ..binary-name) + (constraints-signature constraints super interfaces) + (..class-name super) (|> interfaces - (list/map (|>> product.left ..binary-name)) + (list@map ..class-name) string-array))) definitions) _ (ClassWriter::visitEnd writer)] @@ -185,11 +186,13 @@ [abstract (Opcodes::ACC_ABSTRACT)] ) -(def: $Object Class ["java.lang.Object" (list)]) +(def: $Object + (Type Class) + (type.class "java.lang.Object" (list))) -(def: #export (interface version visibility config name parameters interfaces +(def: #export (interface version visibility config name constraints interfaces definitions) - (-> //.Version //.Visibility //.Class-Config Text (List Parameter) (List Class) //.Def + (-> //.Version //.Visibility //.Class-Config Text (List Constraint) (List (Type Class)) //.Def (host.type [byte])) (let [writer (|> (do-to (ClassWriter::new class-computes) (ClassWriter::visit (version-flag version) @@ -199,25 +202,25 @@ (visibility-flag visibility) (class-flags config)) (..binary-name name) - (parameters-signature parameters $Object interfaces) - (|> $Object product.left ..binary-name) + (constraints-signature constraints $Object interfaces) + (..class-name $Object) (|> interfaces - (list/map (|>> product.left ..binary-name)) + (list@map ..class-name) string-array))) definitions) _ (ClassWriter::visitEnd writer)] (ClassWriter::toByteArray writer))) -(def: #export (method visibility config name type then) - (-> //.Visibility //.Method-Config Text (Descriptor descriptor.Method) //.Inst +(def: #export (method visibility config name [signature descriptor] then) + (-> //.Visibility //.Method-Config Text [(Signature Method) (Descriptor Method)] //.Inst //.Def) (function (_ writer) (let [=method (ClassWriter::visitMethod ($_ i.+ (visibility-flag visibility) (method-flags config)) (..binary-name name) - (descriptor.descriptor type) - (host.null) + (descriptor.descriptor descriptor) + (signature.signature signature) (string-array (list)) writer) _ (MethodVisitor::visitCode =method) @@ -226,8 +229,8 @@ _ (MethodVisitor::visitEnd =method)] writer))) -(def: #export (abstract-method visibility config name type) - (-> //.Visibility //.Method-Config Text (Descriptor descriptor.Method) +(def: #export (abstract-method visibility config name [signature descriptor]) + (-> //.Visibility //.Method-Config Text [(Signature Method) (Descriptor Method)] //.Def) (function (_ writer) (let [=method (ClassWriter::visitMethod ($_ i.+ @@ -235,22 +238,22 @@ (method-flags config) (Opcodes::ACC_ABSTRACT)) (..binary-name name) - (descriptor.descriptor type) - (host.null) + (descriptor.descriptor descriptor) + (signature.signature signature) (string-array (list)) writer) _ (MethodVisitor::visitEnd =method)] writer))) (def: #export (field visibility config name type) - (-> //.Visibility //.Field-Config Text (Descriptor descriptor.Field) //.Def) + (-> //.Visibility //.Field-Config Text (Type Value) //.Def) (function (_ writer) (let [=field (do-to (ClassWriter::visitField ($_ i.+ (visibility-flag visibility) (field-flags config)) (..binary-name name) - (descriptor.descriptor type) - (host.null) + (..descriptor type) + (..signature type) (host.null) writer) (FieldVisitor::visitEnd))] @@ -264,22 +267,22 @@ (visibility-flag visibility) (field-flags config)) (..binary-name name) - (descriptor.descriptor <jvm-type>) - (host.null) + (..descriptor <jvm-type>) + (..signature <jvm-type>) (<prepare> value) writer) (FieldVisitor::visitEnd))] writer)))] - [boolean-field Bit descriptor.boolean function.identity] - [byte-field Int descriptor.byte host.long-to-byte] - [short-field Int descriptor.short host.long-to-short] - [int-field Int descriptor.int host.long-to-int] - [long-field Int descriptor.long function.identity] - [float-field Frac descriptor.float host.double-to-float] - [double-field Frac descriptor.double function.identity] - [char-field Nat descriptor.char (|>> .int host.long-to-int host.int-to-char)] - [string-field Text (descriptor.class "java.lang.String") function.identity] + [boolean-field Bit type.boolean function.identity] + [byte-field Int type.byte host.long-to-byte] + [short-field Int type.short host.long-to-short] + [int-field Int type.int host.long-to-int] + [long-field Int type.long function.identity] + [float-field Frac type.float host.double-to-float] + [double-field Frac type.double function.identity] + [char-field Nat type.char (|>> .int host.long-to-int host.int-to-char)] + [string-field Text (type.class "java.lang.String" (list)) function.identity] ) (def: #export (fuse defs) diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux index 8d5bd3b6e..72d7e58ca 100644 --- a/new-luxc/source/luxc/lang/host/jvm/inst.lux +++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- int char) + [lux (#- Type int char) ["." host (#+ import: do-to)] [abstract [monad (#+ do)]] @@ -23,15 +23,22 @@ [target [jvm [encoding - ["." name]] - [type + ["." name (#+ External)]] + ["." type (#+ Type) ("#@." equivalence) + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] ["." box] - ["." descriptor (#+ Descriptor Primitive) ("#@." equivalence)]]]] + ["." signature (#+ Signature)] + ["." descriptor (#+ Descriptor)] + ["." reflection]]]] [tool [compiler [phase (#+ Operation)]]]] ["." // (#+ Inst)]) +(def: class-name (|>> type.descriptor descriptor.class-name name.read)) +(def: descriptor (|>> type.descriptor descriptor.descriptor)) +(def: reflection (|>> type.reflection reflection.reflection)) + ## [Host] (import: #long java/lang/Object) (import: #long java/lang/String) @@ -239,10 +246,10 @@ (template [<name> <inst>] [(def: #export (<name> class field type) - (-> (Descriptor descriptor.Class) Text (Descriptor descriptor.Field) Inst) + (-> (Type Class) Text (Type Value) Inst) (function (_ visitor) (do-to visitor - (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (descriptor.class-name class) field (descriptor.descriptor type)))))] + (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (..class-name class) field (..descriptor type)))))] [GETSTATIC org/objectweb/asm/Opcodes::GETSTATIC] [PUTSTATIC org/objectweb/asm/Opcodes::PUTSTATIC] @@ -251,44 +258,54 @@ [GETFIELD org/objectweb/asm/Opcodes::GETFIELD] ) -(template [<name> <inst>] - [(def: #export (<name> class) - (-> (Descriptor descriptor.Object) Inst) - (function (_ visitor) - (do-to visitor - (org/objectweb/asm/MethodVisitor::visitTypeInsn (<inst>) (descriptor.class-name class)))))] +(template [<category> <instructions>+] + [(`` (template [<name> <inst>] + [(def: #export (<name> class) + (-> (Type <category>) Inst) + (function (_ visitor) + (do-to visitor + (org/objectweb/asm/MethodVisitor::visitTypeInsn (<inst>) (..class-name class)))))] + + (~~ (template.splice <instructions>+))))] + + [Object + [[CHECKCAST org/objectweb/asm/Opcodes::CHECKCAST] + [ANEWARRAY org/objectweb/asm/Opcodes::ANEWARRAY]]] - [CHECKCAST org/objectweb/asm/Opcodes::CHECKCAST] - [NEW org/objectweb/asm/Opcodes::NEW] - [INSTANCEOF org/objectweb/asm/Opcodes::INSTANCEOF] - [ANEWARRAY org/objectweb/asm/Opcodes::ANEWARRAY] + [Class + [[NEW org/objectweb/asm/Opcodes::NEW] + [INSTANCEOF org/objectweb/asm/Opcodes::INSTANCEOF]]] ) (def: #export (NEWARRAY type) - (-> (Descriptor Primitive) Inst) + (-> (Type Primitive) Inst) (function (_ visitor) (do-to visitor (org/objectweb/asm/MethodVisitor::visitIntInsn (org/objectweb/asm/Opcodes::NEWARRAY) (`` (cond (~~ (template [<descriptor> <opcode>] - [(descriptor@= <descriptor> type) (<opcode>)] + [(type@= <descriptor> type) (<opcode>)] - [descriptor.boolean org/objectweb/asm/Opcodes::T_BOOLEAN] - [descriptor.byte org/objectweb/asm/Opcodes::T_BYTE] - [descriptor.short org/objectweb/asm/Opcodes::T_SHORT] - [descriptor.int org/objectweb/asm/Opcodes::T_INT] - [descriptor.long org/objectweb/asm/Opcodes::T_LONG] - [descriptor.float org/objectweb/asm/Opcodes::T_FLOAT] - [descriptor.double org/objectweb/asm/Opcodes::T_DOUBLE] - [descriptor.char org/objectweb/asm/Opcodes::T_CHAR])) + [type.boolean org/objectweb/asm/Opcodes::T_BOOLEAN] + [type.byte org/objectweb/asm/Opcodes::T_BYTE] + [type.short org/objectweb/asm/Opcodes::T_SHORT] + [type.int org/objectweb/asm/Opcodes::T_INT] + [type.long org/objectweb/asm/Opcodes::T_LONG] + [type.float org/objectweb/asm/Opcodes::T_FLOAT] + [type.double org/objectweb/asm/Opcodes::T_DOUBLE] + [type.char org/objectweb/asm/Opcodes::T_CHAR])) ## else (undefined))))))) (template [<name> <inst>] - [(def: #export (<name> class method-name type interface?) - (-> (Descriptor descriptor.Class) Text (Descriptor descriptor.Method) Bit Inst) + [(def: #export (<name> class method-name [method-signature method-descriptor] interface?) + (-> (Type Class) Text [(Signature Method) (Descriptor Method)] Bit Inst) (function (_ visitor) (do-to visitor - (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>) (descriptor.class-name class) method-name (descriptor.descriptor type) interface?))))] + (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>) + (..class-name class) + method-name + (descriptor.descriptor method-descriptor) + interface?))))] [INVOKESTATIC org/objectweb/asm/Opcodes::INVOKESTATIC] [INVOKEVIRTUAL org/objectweb/asm/Opcodes::INVOKEVIRTUAL] @@ -346,10 +363,10 @@ (org/objectweb/asm/MethodVisitor::visitTableSwitchInsn min max default labels-array))))) (def: #export (try @from @to @handler exception) - (-> //.Label //.Label //.Label (Descriptor descriptor.Class) Inst) + (-> //.Label //.Label //.Label (Type Class) Inst) (function (_ visitor) (do-to visitor - (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (descriptor.class-name exception))))) + (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (..class-name exception))))) (def: #export (label @label) (-> //.Label Inst) @@ -358,8 +375,8 @@ (org/objectweb/asm/MethodVisitor::visitLabel @label)))) (def: #export (array type) - (-> (Descriptor descriptor.Value) Inst) - (case (descriptor.primitive? type) + (-> (Type Value) Inst) + (case (type.primitive? type) (#.Left object) (ANEWARRAY object) @@ -368,18 +385,18 @@ (template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>] [(def: (<name> type) - (-> (Descriptor Primitive) Text) + (-> (Type Primitive) Text) (`` (cond (~~ (template [<descriptor> <output>] - [(descriptor@= <descriptor> type) <output>] + [(type@= <descriptor> type) <output>] - [descriptor.boolean <boolean>] - [descriptor.byte <byte>] - [descriptor.short <short>] - [descriptor.int <int>] - [descriptor.long <long>] - [descriptor.float <float>] - [descriptor.double <double>] - [descriptor.char <char>])) + [type.boolean <boolean>] + [type.byte <byte>] + [type.short <short>] + [type.int <int>] + [type.long <long>] + [type.float <float>] + [type.double <double>] + [type.char <char>])) ## else (undefined))))] @@ -392,15 +409,15 @@ ) (def: #export (wrap type) - (-> (Descriptor Primitive) Inst) - (let [wrapper (descriptor.class (primitive-wrapper type))] - (INVOKESTATIC wrapper "valueOf" (descriptor.method [(list type) wrapper]) #0))) + (-> (Type Primitive) Inst) + (let [wrapper (type.class (primitive-wrapper type) (list))] + (INVOKESTATIC wrapper "valueOf" (type.method [(list type) wrapper (list)]) #0))) (def: #export (unwrap type) - (-> (Descriptor Primitive) Inst) - (let [wrapper (descriptor.class (primitive-wrapper type))] + (-> (Type Primitive) Inst) + (let [wrapper (type.class (primitive-wrapper type) (list))] (|>> (CHECKCAST wrapper) - (INVOKEVIRTUAL wrapper (primitive-unwrap type) (descriptor.method [(list) type]) #0)))) + (INVOKEVIRTUAL wrapper (primitive-unwrap type) (type.method [(list) type (list)]) #0)))) (def: #export (fuse insts) (-> (List Inst) Inst) diff --git a/new-luxc/source/luxc/lang/statement/jvm.lux b/new-luxc/source/luxc/lang/statement/jvm.lux index bc0cd375e..20ba938d1 100644 --- a/new-luxc/source/luxc/lang/statement/jvm.lux +++ b/new-luxc/source/luxc/lang/statement/jvm.lux @@ -1,10 +1,11 @@ (.module: - [lux (#- Definition) + [lux (#- Type Definition) [abstract ["." monad (#+ do)]] [control ["<>" parser - ["<c>" code (#+ Parser)]]] + ["<c>" code (#+ Parser)] + ["<t>" text]]] [data ["." product] [text @@ -16,9 +17,12 @@ ["." check (#+ Check)]] [target [jvm - ["." type (#+ Var Parameter Class Argument Typed Return) + ["." type (#+ Type Constraint Argument Typed) + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] [".T" lux] - ["." descriptor (#+ Descriptor)]]]] + ["." signature] + ["." descriptor (#+ Descriptor)] + ["." parser]]]] [tool [compiler ["." statement (#+ Handler Bundle)] @@ -38,12 +42,14 @@ ["$" jvm (#+ Anchor Inst Definition Operation Phase) ["_." def]]]]]) +(def: signature (|>> type.signature signature.signature)) + (type: Declaration - [Text (List Text)]) + [Text (List (Type Var))]) (def: declaration (Parser Declaration) - (<c>.form (<>.and <c>.text (<>.some <c>.text)))) + (<c>.form (<>.and <c>.text (<>.some jvm.var)))) (type: Inheritance #FinalI @@ -75,14 +81,12 @@ (Parser Annotation) <c>.any) -(def: field-descriptor - (Parser (Descriptor descriptor.Field)) - (:: <>.monad map - (|>> (:coerce (Descriptor descriptor.Field))) - <c>.text)) +(def: field-type + (Parser (Type Value)) + (<t>.embed parser.value <c>.text)) (type: Constant - [Text (List Annotation) (Descriptor descriptor.Field) Code]) + [Text (List Annotation) (Type Value) Code]) (def: constant (Parser Constant) @@ -91,12 +95,12 @@ ($_ <>.and <c>.text (<c>.tuple (<>.some ..annotation)) - ..field-descriptor + ..field-type <c>.any ))) (type: Variable - [Text jvm.Visibility State (List Annotation) (Descriptor descriptor.Field)]) + [Text jvm.Visibility State (List Annotation) (Type Value)]) (def: variable (Parser Variable) @@ -107,7 +111,7 @@ jvm.visibility ..state (<c>.tuple (<>.some ..annotation)) - ..field-descriptor + ..field-type ))) (type: Field @@ -136,9 +140,11 @@ jvm.overriden-method-definition )) -(def: (parameter name) - (-> Text Parameter) - [name [type.object-class (list)] (list)]) +(def: (constraint name) + (-> Text Constraint) + {#type.name name + #type.super-class (type.class "java.lang.Object" (list)) + #type.super-interfaces (list)}) (def: jvm::class (Handler Anchor Inst Definition) @@ -165,7 +171,7 @@ (typeA.with-env (jvm.parameter-types parameters))) #let [mapping (list@fold (function (_ [parameterJ parameterT] mapping) - (dictionary.put parameterJ parameterT mapping)) + (dictionary.put (parser.name parameterJ) parameterT mapping)) luxT.fresh parameters) field-definitions (|> fields @@ -203,11 +209,11 @@ _def.fuse)] super-classT (statement.lift-analysis (typeA.with-env - (luxT.class mapping super-class))) + (luxT.check (luxT.class mapping) (..signature super-class)))) super-interfaceT+ (statement.lift-analysis (typeA.with-env (monad.map check.monad - (luxT.class mapping) + (|>> ..signature (luxT.check (luxT.class mapping))) super-interfaces))) #let [selfT (jvm.inheritance-relationship-type (#.Primitive name (list@map product.right parameters)) super-classT @@ -243,9 +249,9 @@ ## TODO: Handle abstract classes. #AbstractI (undefined) #DefaultI $.noneC) - name (list@map (|>> product.left ..parameter) parameters) + name (list@map (|>> product.left parser.name ..constraint) parameters) super-class super-interfaces - (|>> field-definitions))])) + field-definitions)])) #let [_ (log! (format "Class " name))]] (wrap statement.no-requirements)))])) diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux index 7388e8c30..86d7f9b9a 100644 --- a/new-luxc/source/luxc/lang/translation/jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm.lux @@ -21,7 +21,7 @@ [target [jvm ["." loader (#+ Library)] - [type + ["." type ["." descriptor]]]] [tool [compiler @@ -49,7 +49,7 @@ (type: #export ByteCode Binary) (def: #export value-field Text "_value") -(def: #export $Value (descriptor.class "java.lang.Object")) +(def: #export $Value (type.class "java.lang.Object" (list))) (exception: #export (cannot-load {class Text} {error Text}) (exception.report @@ -93,15 +93,15 @@ bytecode (def.class #jvm.V1_6 #jvm.Public jvm.noneC bytecode-name - (list) ["java.lang.Object" (list)] + (list) $Value (list) (|>> (def.field #jvm.Public ($_ jvm.++F jvm.finalF jvm.staticF) ..value-field ..$Value) (def.method #jvm.Public ($_ jvm.++M jvm.staticM jvm.strictM) "<clinit>" - (descriptor.method [(list) descriptor.void]) + (type.method [(list) type.void (list)]) (|>> valueI - (inst.PUTSTATIC (descriptor.class bytecode-name) ..value-field ..$Value) + (inst.PUTSTATIC (type.class bytecode-name (list)) ..value-field ..$Value) inst.RETURN))))] (io.run (do (try.with io.monad) [_ (loader.store eval-class bytecode library) @@ -151,6 +151,6 @@ (def: #export runtime-class "LuxRuntime") (def: #export function-class "LuxFunction") -(def: #export $Variant (descriptor.array ..$Value)) -(def: #export $Tuple (descriptor.array ..$Value)) -(def: #export $Function (descriptor.class ..function-class)) +(def: #export $Variant (type.array ..$Value)) +(def: #export $Tuple (type.array ..$Value)) +(def: #export $Function (type.class ..function-class (list))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.lux b/new-luxc/source/luxc/lang/translation/jvm/case.lux index f57671f36..d676f2996 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/case.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/case.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- if let case) + [lux (#- Type if let case) [abstract [monad (#+ do)]] [control @@ -10,8 +10,10 @@ ["n" nat]]] [target [jvm - [type - ["." descriptor]]]] + ["." type (#+ Type) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature)]]]] [tool [compiler ["." synthesis (#+ Path Synthesis)] @@ -24,7 +26,7 @@ ["." // ["." runtime]]) -(def: $Runtime (descriptor.class //.runtime-class)) +(def: $Runtime (type.class //.runtime-class (list))) (def: (pop-altI stack-depth) (-> Nat Inst) @@ -43,7 +45,7 @@ (def: pushI Inst - (|>> (_.INVOKESTATIC $Runtime "pm_push" (descriptor.method [(list runtime.$Stack //.$Value) runtime.$Stack]) #0))) + (|>> (_.INVOKESTATIC $Runtime "pm_push" (type.method [(list runtime.$Stack //.$Value) runtime.$Stack (list)]) #0))) (def: (path' phase stack-depth @else @end path) (-> Phase Nat Label Label Path (Operation Inst)) @@ -58,19 +60,19 @@ (^ (synthesis.path/bit value)) (operation@wrap (.let [jumpI (.if value _.IFEQ _.IFNE)] (|>> peekI - (_.unwrap descriptor.boolean) + (_.unwrap type.boolean) (jumpI @else)))) (^ (synthesis.path/i64 value)) (operation@wrap (|>> peekI - (_.unwrap descriptor.long) + (_.unwrap type.long) (_.long (.int value)) _.LCMP (_.IFNE @else))) (^ (synthesis.path/f64 value)) (operation@wrap (|>> peekI - (_.unwrap descriptor.double) + (_.unwrap type.double) (_.double value) _.DCMPL (_.IFNE @else))) @@ -78,9 +80,9 @@ (^ (synthesis.path/text value)) (operation@wrap (|>> peekI (_.string value) - (_.INVOKEVIRTUAL (descriptor.class "java.lang.Object") + (_.INVOKEVIRTUAL (type.class "java.lang.Object" (list)) "equals" - (descriptor.method [(list //.$Value) descriptor.boolean]) + (type.method [(list //.$Value) type.boolean (list)]) #0) (_.IFEQ @else))) @@ -99,7 +101,7 @@ (_.CHECKCAST //.$Variant) (_.int (.int (<prepare> idx))) <flag> - (_.INVOKESTATIC $Runtime "pm_variant" (descriptor.method [(list //.$Variant runtime.$Tag runtime.$Flag) runtime.$Value]) #0) + (_.INVOKESTATIC $Runtime "pm_variant" (type.method [(list //.$Variant runtime.$Tag runtime.$Flag) runtime.$Value (list)]) #0) _.DUP (_.IFNULL @fail) (_.GOTO @success) @@ -117,7 +119,7 @@ _.AALOAD lefts - (_.INVOKESTATIC $Runtime "tuple_left" (descriptor.method [(list //.$Tuple runtime.$Index) //.$Value]) #0))] + (_.INVOKESTATIC $Runtime "tuple_left" (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)]) #0))] (|>> peekI (_.CHECKCAST //.$Tuple) (_.int (.int lefts)) @@ -128,7 +130,7 @@ (operation@wrap (|>> peekI (_.CHECKCAST //.$Tuple) (_.int (.int lefts)) - (_.INVOKESTATIC $Runtime "tuple_right" (descriptor.method [(list //.$Tuple runtime.$Index) //.$Value]) #0) + (_.INVOKESTATIC $Runtime "tuple_right" (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)]) #0) pushI)) ## Extra optimization @@ -154,7 +156,7 @@ (wrap (|>> peekI (_.CHECKCAST //.$Tuple) (_.int (.int lefts)) - (_.INVOKESTATIC $Runtime <getter> (descriptor.method [(list //.$Tuple runtime.$Index) //.$Value]) #0) + (_.INVOKESTATIC $Runtime <getter> (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)]) #0) (_.ASTORE register) then!)))) ([synthesis.member/left "tuple_left"] @@ -187,7 +189,7 @@ (wrap (|>> pathI (_.label @else) _.POP - (_.INVOKESTATIC $Runtime "pm_fail" (descriptor.method [(list) descriptor.void]) #0) + (_.INVOKESTATIC $Runtime "pm_fail" (type.method [(list) type.void (list)]) #0) _.NULL (_.GOTO @end))))) @@ -200,7 +202,7 @@ (wrap (<| _.with-label (function (_ @else)) _.with-label (function (_ @end)) (|>> testI - (_.unwrap descriptor.boolean) + (_.unwrap type.boolean) (_.IFEQ @else) thenI (_.GOTO @end) diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.lux b/new-luxc/source/luxc/lang/translation/jvm/function.lux index dca622efa..9592510ab 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/function.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/function.lux @@ -13,8 +13,10 @@ ["." list ("#@." functor monoid)]]] [target [jvm - [type - ["." descriptor (#+ Descriptor Class Method Value)]]]] + ["." type (#+ Type) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature)]]]] [tool [compiler [arity (#+ Arity)] @@ -39,33 +41,34 @@ (-> Arity Bit) (n.> 1 arity)) -(def: reset-method - (-> (Descriptor Class) (Descriptor Method)) - (|>> [(list)] descriptor.method)) +(def: (reset-method return) + (-> (Type Class) [(Signature Method) (Descriptor Method)]) + (type.method [(list) return (list)])) (def: (captured-args env) - (-> Environment (List (Descriptor Value))) + (-> Environment (List (Type Value))) (list.repeat (list.size env) //.$Value)) (def: (init-method env arity) - (-> Environment Arity (Descriptor Method)) + (-> Environment Arity [(Signature Method) (Descriptor Method)]) (if (poly-arg? arity) - (descriptor.method [(list.concat (list (captured-args env) - (list descriptor.int) - (list.repeat (dec arity) //.$Value))) - descriptor.void]) - (descriptor.method [(captured-args env) descriptor.void]))) + (type.method [(list.concat (list (captured-args env) + (list type.int) + (list.repeat (dec arity) //.$Value))) + type.void + (list)]) + (type.method [(captured-args env) type.void (list)]))) (def: (implementation-method arity) - (descriptor.method [(list.repeat arity //.$Value) //.$Value])) + (type.method [(list.repeat arity //.$Value) //.$Value (list)])) (def: get-amount-of-partialsI Inst (|>> (_.ALOAD 0) - (_.GETFIELD //.$Function runtime.partials-field descriptor.int))) + (_.GETFIELD //.$Function runtime.partials-field type.int))) (def: (load-fieldI class field) - (-> (Descriptor Class) Text Inst) + (-> (Type Class) Text Inst) (|>> (_.ALOAD 0) (_.GETFIELD class field //.$Value))) @@ -114,7 +117,7 @@ function.identity)) (def: (instance class arity env) - (-> (Descriptor Class) Arity Environment (Operation Inst)) + (-> (Type Class) Arity Environment (Operation Inst)) (do phase.monad [captureI+ (monad.map @ reference.variable env) #let [argsI (if (poly-arg? arity) @@ -129,7 +132,7 @@ (_.INVOKESPECIAL class "<init>" (init-method env arity) #0))))) (def: (with-reset class arity env) - (-> (Descriptor Class) Arity Environment Def) + (-> (Type Class) Arity Environment Def) (def.method #$.Public $.noneM "reset" (reset-method class) (if (poly-arg? arity) (let [env-size (list.size env) @@ -160,7 +163,7 @@ _.ARETURN))) (def: function-init-method - (descriptor.method [(list descriptor.int) descriptor.void])) + (type.method [(list type.int) type.void (list)])) (def: (function-init arity env-size) (-> Arity Nat Inst) @@ -171,7 +174,7 @@ (_.INVOKESPECIAL //.$Function "<init>" function-init-method #0)))) (def: (with-init class env arity) - (-> (Descriptor Class) Environment Arity Def) + (-> (Type Class) Environment Arity Def) (let [env-size (list.size env) offset-partial (: (-> Nat Nat) (|>> inc (n.+ env-size))) @@ -200,7 +203,7 @@ _.RETURN)))) (def: (with-apply class env function-arity @begin bodyI apply-arity) - (-> (Descriptor Class) Environment Arity Label Inst Arity + (-> (Type Class) Environment Arity Label Inst Arity Def) (let [num-partials (dec function-arity) @default ($.new-label []) @@ -261,7 +264,7 @@ (_.TABLESWITCH +0 (|> num-partials dec .int) @default @labels) casesI - (_.INVOKESTATIC runtime.$Runtime "apply_fail" (descriptor.method [(list) descriptor.void]) #0) + (_.INVOKESTATIC runtime.$Runtime "apply_fail" (type.method [(list) type.void (list)]) #0) _.NULL _.ARETURN )))) @@ -269,7 +272,7 @@ (def: #export (with-function @begin class env arity bodyI) (-> Label Text Environment Arity Inst (Operation [Def Inst])) - (let [classD (descriptor.class class) + (let [classD (type.class class (list)) env-size (list.size env) applyD (: Def (if (poly-arg? arity) diff --git a/new-luxc/source/luxc/lang/translation/jvm/primitive.lux b/new-luxc/source/luxc/lang/translation/jvm/primitive.lux index d5f8d56cb..873c363bd 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/primitive.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/primitive.lux @@ -2,8 +2,7 @@ [lux (#- i64) [target [jvm - [type - ["." descriptor]]]] + ["." type]]] [tool [compiler [phase ("operation@." monad)]]]] @@ -15,7 +14,7 @@ (def: #export bit (-> Bit (Operation Inst)) - (let [Boolean (descriptor.class "java.lang.Boolean")] + (let [Boolean (type.class "java.lang.Boolean" (list))] (function (_ value) (operation@wrap (_.GETSTATIC Boolean (if value "TRUE" "FALSE") Boolean))))) @@ -25,7 +24,7 @@ (let [loadI (|> value <load>)] (operation@wrap (|>> loadI <wrap>))))] - [i64 (I64 Any) (<| _.long .int) (_.wrap descriptor.long)] - [f64 Frac _.double (_.wrap descriptor.double)] + [i64 (I64 Any) (<| _.long .int) (_.wrap type.long)] + [f64 Frac _.double (_.wrap type.double)] [text Text _.string (<|)] ) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux index 6e7891460..06ae2ba26 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux @@ -16,8 +16,7 @@ ["." dictionary]]] [target [jvm - [type - ["." descriptor]]]] + ["." type]]] [tool [compiler ["." synthesis (#+ Synthesis %synthesis)] @@ -53,19 +52,19 @@ (#static MIN_VALUE Double) (#static MAX_VALUE Double)) -(def: $String (descriptor.class "java.lang.String")) -(def: $CharSequence (descriptor.class "java.lang.CharSequence")) -(def: $System (descriptor.class "java.lang.System")) -(def: $Object (descriptor.class "java.lang.Object")) +(def: $String (type.class "java.lang.String" (list))) +(def: $CharSequence (type.class "java.lang.CharSequence" (list))) +(def: $System (type.class "java.lang.System" (list))) +(def: $Object (type.class "java.lang.Object" (list))) -(def: lux-intI Inst (|>> _.I2L (_.wrap descriptor.long))) -(def: jvm-intI Inst (|>> (_.unwrap descriptor.long) _.L2I)) +(def: lux-intI Inst (|>> _.I2L (_.wrap type.long))) +(def: jvm-intI Inst (|>> (_.unwrap type.long) _.L2I)) (def: check-stringI Inst (_.CHECKCAST $String)) (def: (predicateI tester) (-> (-> Label Inst) Inst) - (let [$Boolean (descriptor.class "java.lang.Boolean")] + (let [$Boolean (type.class "java.lang.Boolean" (list))] (<| _.with-label (function (_ @then)) _.with-label (function (_ @end)) (|>> (tester @then) @@ -111,7 +110,7 @@ conditionalsG (|> conditionalsG+ (list@map product.right) _.fuse)]] - (wrap (|>> inputG (_.unwrap descriptor.long) _.L2I + (wrap (|>> inputG (_.unwrap type.long) _.L2I (_.LOOKUPSWITCH @else table) conditionalsG (_.label @else) @@ -130,15 +129,15 @@ (|>> riskyI (_.CHECKCAST ///.$Function) (_.INVOKESTATIC runtime.$Runtime "try" - (descriptor.method [(list ///.$Function) ///.$Variant]) + (type.method [(list ///.$Function) ///.$Variant (list)]) #0))) (template [<name> <op>] [(def: (<name> [maskI inputI]) (Binary Inst) - (|>> inputI (_.unwrap descriptor.long) - maskI (_.unwrap descriptor.long) - <op> (_.wrap descriptor.long)))] + (|>> inputI (_.unwrap type.long) + maskI (_.unwrap type.long) + <op> (_.wrap type.long)))] [i64::and _.LAND] [i64::or _.LOR] @@ -148,10 +147,10 @@ (template [<name> <op>] [(def: (<name> [shiftI inputI]) (Binary Inst) - (|>> inputI (_.unwrap descriptor.long) + (|>> inputI (_.unwrap type.long) shiftI jvm-intI <op> - (_.wrap descriptor.long)))] + (_.wrap type.long)))] [i64::left-shift _.LSHL] [i64::arithmetic-right-shift _.LSHR] @@ -163,9 +162,9 @@ (Nullary Inst) (|>> <const> (_.wrap <type>)))] - [f64::smallest (_.double (Double::MIN_VALUE)) descriptor.double] - [f64::min (_.double (f.* -1.0 (Double::MAX_VALUE))) descriptor.double] - [f64::max (_.double (Double::MAX_VALUE)) descriptor.double] + [f64::smallest (_.double (Double::MIN_VALUE)) type.double] + [f64::min (_.double (f.* -1.0 (Double::MAX_VALUE))) type.double] + [f64::max (_.double (Double::MAX_VALUE)) type.double] ) (template [<name> <type> <op>] @@ -176,25 +175,25 @@ <op> (_.wrap <type>)))] - [i64::+ descriptor.long _.LADD] - [i64::- descriptor.long _.LSUB] - [i64::* descriptor.long _.LMUL] - [i64::/ descriptor.long _.LDIV] - [i64::% descriptor.long _.LREM] + [i64::+ type.long _.LADD] + [i64::- type.long _.LSUB] + [i64::* type.long _.LMUL] + [i64::/ type.long _.LDIV] + [i64::% type.long _.LREM] - [f64::+ descriptor.double _.DADD] - [f64::- descriptor.double _.DSUB] - [f64::* descriptor.double _.DMUL] - [f64::/ descriptor.double _.DDIV] - [f64::% descriptor.double _.DREM] + [f64::+ type.double _.DADD] + [f64::- type.double _.DSUB] + [f64::* type.double _.DMUL] + [f64::/ type.double _.DDIV] + [f64::% type.double _.DREM] ) -(template [<eq> <lt> <descriptor> <cmp>] +(template [<eq> <lt> <type> <cmp>] [(template [<name> <reference>] [(def: (<name> [paramI subjectI]) (Binary Inst) - (|>> subjectI (_.unwrap <descriptor>) - paramI (_.unwrap <descriptor>) + (|>> subjectI (_.unwrap <type>) + paramI (_.unwrap <type>) <cmp> (_.int <reference>) (predicateI _.IF_ICMPEQ)))] @@ -202,8 +201,8 @@ [<eq> +0] [<lt> -1])] - [i64::= i64::< descriptor.long _.LCMP] - [f64::= f64::< descriptor.double _.DCMPG] + [i64::= i64::< type.long _.LCMP] + [f64::= f64::< type.double _.DCMPG] ) (template [<name> <prepare> <transform>] @@ -211,22 +210,22 @@ (Unary Inst) (|>> inputI <prepare> <transform>))] - [i64::f64 (_.unwrap descriptor.long) (<| (_.wrap descriptor.double) _.L2D)] - [i64::char (_.unwrap descriptor.long) - ((|>> _.L2I _.I2C (_.INVOKESTATIC (descriptor.class "java.lang.Character") "toString" (descriptor.method [(list descriptor.char) $String]) #0)))] + [i64::f64 (_.unwrap type.long) (<| (_.wrap type.double) _.L2D)] + [i64::char (_.unwrap type.long) + ((|>> _.L2I _.I2C (_.INVOKESTATIC (type.class "java.lang.Character" (list)) "toString" (type.method [(list type.char) $String (list)]) #0)))] - [f64::i64 (_.unwrap descriptor.double) (<| (_.wrap descriptor.long) _.D2L)] - [f64::encode (_.unwrap descriptor.double) - (_.INVOKESTATIC (descriptor.class "java.lang.Double") "toString" (descriptor.method [(list descriptor.double) $String]) #0)] + [f64::i64 (_.unwrap type.double) (<| (_.wrap type.long) _.D2L)] + [f64::encode (_.unwrap type.double) + (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "toString" (type.method [(list type.double) $String (list)]) #0)] [f64::decode ..check-stringI - (_.INVOKESTATIC runtime.$Runtime "decode_frac" (descriptor.method [(list $String) ///.$Variant]) #0)] + (_.INVOKESTATIC runtime.$Runtime "decode_frac" (type.method [(list $String) ///.$Variant (list)]) #0)] ) (def: (text::size inputI) (Unary Inst) (|>> inputI ..check-stringI - (_.INVOKEVIRTUAL $String "length" (descriptor.method [(list) descriptor.int]) #0) + (_.INVOKEVIRTUAL $String "length" (type.method [(list) type.int (list)]) #0) lux-intI)) (template [<name> <pre-subject> <pre-param> <op> <post>] @@ -237,13 +236,13 @@ <op> <post>))] [text::= (<|) (<|) - (_.INVOKEVIRTUAL $Object "equals" (descriptor.method [(list $Object) descriptor.boolean]) #0) - (_.wrap descriptor.boolean)] + (_.INVOKEVIRTUAL $Object "equals" (type.method [(list $Object) type.boolean (list)]) #0) + (_.wrap type.boolean)] [text::< ..check-stringI ..check-stringI - (_.INVOKEVIRTUAL $String "compareTo" (descriptor.method [(list $String) descriptor.int]) #0) + (_.INVOKEVIRTUAL $String "compareTo" (type.method [(list $String) type.int (list)]) #0) (predicateI _.IFLT)] [text::char ..check-stringI jvm-intI - (_.INVOKEVIRTUAL $String "charAt" (descriptor.method [(list descriptor.int) descriptor.char]) #0) + (_.INVOKEVIRTUAL $String "charAt" (type.method [(list type.int) type.char (list)]) #0) lux-intI] ) @@ -251,16 +250,16 @@ (Binary Inst) (|>> leftI ..check-stringI rightI ..check-stringI - (_.INVOKEVIRTUAL $String "concat" (descriptor.method [(list $String) $String]) #0))) + (_.INVOKEVIRTUAL $String "concat" (type.method [(list $String) $String (list)]) #0))) (def: (text::clip [startI endI subjectI]) (Trinary Inst) (|>> subjectI ..check-stringI startI jvm-intI endI jvm-intI - (_.INVOKEVIRTUAL $String "substring" (descriptor.method [(list descriptor.int descriptor.int) $String]) #0))) + (_.INVOKEVIRTUAL $String "substring" (type.method [(list type.int type.int) $String (list)]) #0))) -(def: index-method (descriptor.method [(list $String descriptor.int) descriptor.int])) +(def: index-method (type.method [(list $String type.int) type.int (list)])) (def: (text::index [startI partI textI]) (Trinary Inst) (<| _.with-label (function (_ @not-found)) @@ -280,10 +279,10 @@ runtime.noneI (_.label @end)))) -(def: string-method (descriptor.method [(list $String) descriptor.void])) +(def: string-method (type.method [(list $String) type.void (list)])) (def: (io::log messageI) (Unary Inst) - (let [$PrintStream (descriptor.class "java.io.PrintStream")] + (let [$PrintStream (type.class "java.io.PrintStream" (list))] (|>> (_.GETSTATIC $System "out" $PrintStream) messageI ..check-stringI @@ -292,7 +291,7 @@ (def: (io::error messageI) (Unary Inst) - (let [$Error (descriptor.class "java.lang.Error")] + (let [$Error (type.class "java.lang.Error" (list))] (|>> (_.NEW $Error) _.DUP messageI @@ -303,13 +302,13 @@ (def: (io::exit codeI) (Unary Inst) (|>> codeI jvm-intI - (_.INVOKESTATIC $System "exit" (descriptor.method [(list descriptor.int) descriptor.void]) #0) + (_.INVOKESTATIC $System "exit" (type.method [(list type.int) type.void (list)]) #0) _.NULL)) (def: (io::current-time _) (Nullary Inst) - (|>> (_.INVOKESTATIC $System "currentTimeMillis" (descriptor.method [(list) descriptor.long]) #0) - (_.wrap descriptor.long))) + (|>> (_.INVOKESTATIC $System "currentTimeMillis" (type.method [(list) type.long (list)]) #0) + (_.wrap type.long))) (def: bundle::lux Bundle diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux index a51d1715b..58643797b 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- primitive int char) + [lux (#- Type primitive int char type) [abstract ["." monad (#+ do)]] [control @@ -13,17 +13,20 @@ ["." maybe] [number ["." nat]] - ["." text] + ["." text ("#@." equivalence)] [collection ["." list ("#@." monad)] ["." dictionary (#+ Dictionary)] ["." set]]] [target - ["." jvm #_ - ["#" type (#+ Bound Generic Class Var Typed Argument Return) + [jvm + ["." type (#+ Type Typed Argument) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] ["." box] ["." reflection] - ["." descriptor (#+ Descriptor Value Primitive Object Method)]]]] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature)] + ["." parser]]]] [tool [compiler [analysis (#+ Environment)] @@ -52,8 +55,6 @@ ["#." reference] ["#." function]]]) -(exception: #export invalid-syntax-for-argument-generation) - (template [<name> <inst>] [(def: <name> Inst @@ -172,7 +173,7 @@ [double::% _.DREM] ) -(def: $Boolean (descriptor.class box.boolean)) +(def: $Boolean (type.class box.boolean (list))) (def: falseI (_.GETSTATIC $Boolean "FALSE" $Boolean)) (def: trueI (_.GETSTATIC $Boolean "TRUE" $Boolean)) @@ -225,7 +226,7 @@ (def: int Bundle - (<| (bundle.prefix reflection.int) + (<| (bundle.prefix (reflection.reflection reflection.int)) (|> (: Bundle bundle.empty) (bundle.install "+" (binary int::+)) (bundle.install "-" (binary int::-)) @@ -244,7 +245,7 @@ (def: long Bundle - (<| (bundle.prefix reflection.long) + (<| (bundle.prefix (reflection.reflection reflection.long)) (|> (: Bundle bundle.empty) (bundle.install "+" (binary long::+)) (bundle.install "-" (binary long::-)) @@ -263,7 +264,7 @@ (def: float Bundle - (<| (bundle.prefix reflection.float) + (<| (bundle.prefix (reflection.reflection reflection.float)) (|> (: Bundle bundle.empty) (bundle.install "+" (binary float::+)) (bundle.install "-" (binary float::-)) @@ -276,7 +277,7 @@ (def: double Bundle - (<| (bundle.prefix reflection.double) + (<| (bundle.prefix (reflection.reflection reflection.double)) (|> (: Bundle bundle.empty) (bundle.install "+" (binary double::+)) (bundle.install "-" (binary double::-)) @@ -289,36 +290,42 @@ (def: char Bundle - (<| (bundle.prefix reflection.char) + (<| (bundle.prefix (reflection.reflection reflection.char)) (|> (: Bundle bundle.empty) (bundle.install "=" (binary char::=)) (bundle.install "<" (binary char::<)) ))) (def: (array-java-type nesting elem-class) - (-> Nat Text (Descriptor Object)) - (descriptor.array (case nesting - 1 (case elem-class - (^ (static reflection.boolean)) descriptor.boolean - (^ (static reflection.byte)) descriptor.byte - (^ (static reflection.short)) descriptor.short - (^ (static reflection.int)) descriptor.int - (^ (static reflection.long)) descriptor.long - (^ (static reflection.float)) descriptor.float - (^ (static reflection.double)) descriptor.double - (^ (static reflection.char)) descriptor.char - _ (descriptor.class elem-class)) - _ (array-java-type (dec nesting) elem-class)))) + (-> Nat Text (Type Object)) + (type.array (case nesting + 0 (undefined) + 1 (`` (cond (~~ (template [<type>] + [(text@= (reflection.reflection (type.reflection <type>)) + elem-class) + <type>] + + [type.boolean] + [type.byte] + [type.short] + [type.int] + [type.long] + [type.float] + [type.double] + [type.char])) + ## else + (type.class elem-class (list)))) + _ (array-java-type (dec nesting) elem-class)))) (def: (primitive-array-length-handler jvm-primitive) - (-> (Descriptor Primitive) Handler) + (-> (Type Primitive) Handler) (..custom [<s>.any (function (_ extension-name generate arrayS) (do phase.monad [arrayI (generate arrayS)] (wrap (|>> arrayI - (_.CHECKCAST (descriptor.array jvm-primitive)) + (_.CHECKCAST (type.array jvm-primitive)) _.ARRAYLENGTH))))])) (def: (array::length::object extension-name generate inputs) @@ -337,7 +344,7 @@ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) (def: (new-primitive-array-handler jvm-primitive) - (-> (Descriptor Primitive) Handler) + (-> (Type Primitive) Handler) (function (_ extension-name generate inputs) (case inputs (^ (list lengthS)) @@ -364,7 +371,7 @@ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) (def: (read-primitive-array-handler jvm-primitive loadI) - (-> (Descriptor Primitive) Inst Handler) + (-> (Type Primitive) Inst Handler) (function (_ extension-name generate inputs) (case inputs (^ (list idxS arrayS)) @@ -372,7 +379,7 @@ [arrayI (generate arrayS) idxI (generate idxS)] (wrap (|>> arrayI - (_.CHECKCAST (descriptor.array jvm-primitive)) + (_.CHECKCAST (type.array jvm-primitive)) idxI loadI))) @@ -398,7 +405,7 @@ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) (def: (write-primitive-array-handler jvm-primitive storeI) - (-> (Descriptor Primitive) Inst Handler) + (-> (Type Primitive) Inst Handler) (function (_ extension-name generate inputs) (case inputs (^ (list idxS valueS arrayS)) @@ -407,7 +414,7 @@ idxI (generate idxS) valueI (generate valueS)] (wrap (|>> arrayI - (_.CHECKCAST (descriptor.array jvm-primitive)) + (_.CHECKCAST (type.array jvm-primitive)) _.DUP idxI valueI @@ -444,47 +451,47 @@ (|> bundle.empty (dictionary.merge (<| (bundle.prefix "length") (|> bundle.empty - (bundle.install reflection.boolean (primitive-array-length-handler descriptor.boolean)) - (bundle.install reflection.byte (primitive-array-length-handler descriptor.byte)) - (bundle.install reflection.short (primitive-array-length-handler descriptor.short)) - (bundle.install reflection.int (primitive-array-length-handler descriptor.int)) - (bundle.install reflection.long (primitive-array-length-handler descriptor.long)) - (bundle.install reflection.float (primitive-array-length-handler descriptor.float)) - (bundle.install reflection.double (primitive-array-length-handler descriptor.double)) - (bundle.install reflection.char (primitive-array-length-handler descriptor.char)) + (bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler type.boolean)) + (bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler type.byte)) + (bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler type.short)) + (bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler type.int)) + (bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler type.long)) + (bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler type.float)) + (bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler type.double)) + (bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler type.char)) (bundle.install "object" array::length::object)))) (dictionary.merge (<| (bundle.prefix "new") (|> bundle.empty - (bundle.install reflection.boolean (new-primitive-array-handler descriptor.boolean)) - (bundle.install reflection.byte (new-primitive-array-handler descriptor.byte)) - (bundle.install reflection.short (new-primitive-array-handler descriptor.short)) - (bundle.install reflection.int (new-primitive-array-handler descriptor.int)) - (bundle.install reflection.long (new-primitive-array-handler descriptor.long)) - (bundle.install reflection.float (new-primitive-array-handler descriptor.float)) - (bundle.install reflection.double (new-primitive-array-handler descriptor.double)) - (bundle.install reflection.char (new-primitive-array-handler descriptor.char)) + (bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler type.boolean)) + (bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler type.byte)) + (bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler type.short)) + (bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler type.int)) + (bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler type.long)) + (bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler type.float)) + (bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler type.double)) + (bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler type.char)) (bundle.install "object" array::new::object)))) (dictionary.merge (<| (bundle.prefix "read") (|> bundle.empty - (bundle.install reflection.boolean (read-primitive-array-handler descriptor.boolean _.BALOAD)) - (bundle.install reflection.byte (read-primitive-array-handler descriptor.byte _.BALOAD)) - (bundle.install reflection.short (read-primitive-array-handler descriptor.short _.SALOAD)) - (bundle.install reflection.int (read-primitive-array-handler descriptor.int _.IALOAD)) - (bundle.install reflection.long (read-primitive-array-handler descriptor.long _.LALOAD)) - (bundle.install reflection.float (read-primitive-array-handler descriptor.float _.FALOAD)) - (bundle.install reflection.double (read-primitive-array-handler descriptor.double _.DALOAD)) - (bundle.install reflection.char (read-primitive-array-handler descriptor.char _.CALOAD)) + (bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler type.boolean _.BALOAD)) + (bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler type.byte _.BALOAD)) + (bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler type.short _.SALOAD)) + (bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler type.int _.IALOAD)) + (bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler type.long _.LALOAD)) + (bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler type.float _.FALOAD)) + (bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler type.double _.DALOAD)) + (bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler type.char _.CALOAD)) (bundle.install "object" array::read::object)))) (dictionary.merge (<| (bundle.prefix "write") (|> bundle.empty - (bundle.install reflection.boolean (write-primitive-array-handler descriptor.boolean _.BASTORE)) - (bundle.install reflection.byte (write-primitive-array-handler descriptor.byte _.BASTORE)) - (bundle.install reflection.short (write-primitive-array-handler descriptor.short _.SASTORE)) - (bundle.install reflection.int (write-primitive-array-handler descriptor.int _.IASTORE)) - (bundle.install reflection.long (write-primitive-array-handler descriptor.long _.LASTORE)) - (bundle.install reflection.float (write-primitive-array-handler descriptor.float _.FASTORE)) - (bundle.install reflection.double (write-primitive-array-handler descriptor.double _.DASTORE)) - (bundle.install reflection.char (write-primitive-array-handler descriptor.char _.CASTORE)) + (bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler type.boolean _.BASTORE)) + (bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler type.byte _.BASTORE)) + (bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler type.short _.SASTORE)) + (bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler type.int _.IASTORE)) + (bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler type.long _.LASTORE)) + (bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler type.float _.FASTORE)) + (bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler type.double _.DASTORE)) + (bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler type.char _.CASTORE)) (bundle.install "object" array::write::object)))) ))) @@ -518,7 +525,7 @@ (|>> exceptionI _.ATHROW)) -(def: $Class (descriptor.class "java.lang.Class")) +(def: $Class (type.class "java.lang.Class" (list))) (def: (object::class extension-name generate inputs) Handler @@ -528,8 +535,9 @@ [] (wrap (|>> (_.string class) (_.INVOKESTATIC $Class "forName" - (descriptor.method [(list (descriptor.class "java.lang.String")) - $Class]) + (type.method [(list (type.class "java.lang.String" (list))) + $Class + (list)]) false)))) _ @@ -543,8 +551,8 @@ (do phase.monad [objectI (generate objectS)] (wrap (|>> objectI - (_.INSTANCEOF (descriptor.class class)) - (_.wrap descriptor.boolean)))))])) + (_.INSTANCEOF (type.class class (list))) + (_.wrap type.boolean)))))])) (def: (object::cast extension-name generate inputs) Handler @@ -552,25 +560,29 @@ (^ (list (synthesis.text from) (synthesis.text to) valueS)) (do phase.monad [valueI (generate valueS)] - (case [from to] - ## Wrap - (^template [<primitive> <object> <type>] - (^ [(static <primitive>) (static <object>)]) - (wrap (|>> valueI (_.wrap <type>))) - - (^ [(static <object>) (static <primitive>)]) - (wrap (|>> valueI (_.unwrap <type>)))) - ([reflection.boolean box.boolean descriptor.boolean] - [reflection.byte box.byte descriptor.byte] - [reflection.short box.short descriptor.short] - [reflection.int box.int descriptor.int] - [reflection.long box.long descriptor.long] - [reflection.float box.float descriptor.float] - [reflection.double box.double descriptor.double] - [reflection.char box.char descriptor.char]) - - _ - (wrap valueI))) + (`` (cond (~~ (template [<object> <type>] + [(and (text@= (reflection.reflection (type.reflection <type>)) + from) + (text@= <object> + to)) + (wrap (|>> valueI (_.wrap <type>))) + + (and (text@= <object> + from) + (text@= (reflection.reflection (type.reflection <type>)) + to)) + (wrap (|>> valueI (_.unwrap <type>)))] + + [box.boolean type.boolean] + [box.byte type.byte] + [box.short type.short] + [box.int type.int] + [box.long type.long] + [box.float type.float] + [box.double type.double] + [box.char type.char])) + ## else + (wrap valueI)))) _ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) @@ -589,211 +601,187 @@ ))) (def: primitives - (Dictionary Text (Descriptor Primitive)) - (|> (list [reflection.boolean descriptor.boolean] - [reflection.byte descriptor.byte] - [reflection.short descriptor.short] - [reflection.int descriptor.int] - [reflection.long descriptor.long] - [reflection.float descriptor.float] - [reflection.double descriptor.double] - [reflection.char descriptor.char]) + (Dictionary Text (Type Primitive)) + (|> (list [(reflection.reflection reflection.boolean) type.boolean] + [(reflection.reflection reflection.byte) type.byte] + [(reflection.reflection reflection.short) type.short] + [(reflection.reflection reflection.int) type.int] + [(reflection.reflection reflection.long) type.long] + [(reflection.reflection reflection.float) type.float] + [(reflection.reflection reflection.double) type.double] + [(reflection.reflection reflection.char) type.char]) (dictionary.from-list text.hash))) -(def: (static::get extension-name generate inputs) +(def: static::get Handler - (case inputs - (^ (list (synthesis.text class) - (synthesis.text field) - (synthesis.text unboxed))) - (do phase.monad - [] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap (_.GETSTATIC (descriptor.class class) field primitive)) - - #.None - (wrap (_.GETSTATIC (descriptor.class class) field (descriptor.class unboxed))))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) - -(def: (static::put extension-name generate inputs) + (..custom + [($_ <>.and <s>.text <s>.text <s>.text) + (function (_ extension-name generate [class field unboxed]) + (do phase.monad + [] + (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (wrap (_.GETSTATIC (type.class class (list)) field primitive)) + + #.None + (wrap (_.GETSTATIC (type.class class (list)) field (type.class unboxed (list)))))))])) + +(def: static::put Handler - (case inputs - (^ (list (synthesis.text class) - (synthesis.text field) - (synthesis.text unboxed) - valueS)) - (do phase.monad - [valueI (generate valueS) - #let [$class (descriptor.class class)]] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap (|>> valueI - (_.PUTSTATIC $class field primitive) - (_.string synthesis.unit))) - - #.None - (wrap (|>> valueI - (_.CHECKCAST $class) - (_.PUTSTATIC $class field $class) - (_.string synthesis.unit))))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) - -(def: (virtual::get extension-name generate inputs) + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any) + (function (_ extension-name generate [class field unboxed valueS]) + (do phase.monad + [valueI (generate valueS) + #let [$class (type.class class (list))]] + (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (wrap (|>> valueI + (_.PUTSTATIC $class field primitive) + (_.string synthesis.unit))) + + #.None + (wrap (|>> valueI + (_.CHECKCAST $class) + (_.PUTSTATIC $class field $class) + (_.string synthesis.unit))))))])) + +(def: virtual::get Handler - (case inputs - (^ (list (synthesis.text class) - (synthesis.text field) - (synthesis.text unboxed) - objectS)) - (do phase.monad - [objectI (generate objectS) - #let [$class (descriptor.class class) - getI (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.GETFIELD $class field primitive) - - #.None - (_.GETFIELD $class field (descriptor.class unboxed)))]] - (wrap (|>> objectI - (_.CHECKCAST $class) - getI))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any) + (function (_ extension-name generate [class field unboxed objectS]) + (do phase.monad + [objectI (generate objectS) + #let [$class (type.class class (list)) + getI (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (_.GETFIELD $class field primitive) + + #.None + (_.GETFIELD $class field (type.class unboxed (list))))]] + (wrap (|>> objectI + (_.CHECKCAST $class) + getI))))])) -(def: (virtual::put extension-name generate inputs) +(def: virtual::put Handler - (case inputs - (^ (list (synthesis.text class) - (synthesis.text field) - (synthesis.text unboxed) - valueS - objectS)) - (do phase.monad - [valueI (generate valueS) - objectI (generate objectS) - #let [$class (descriptor.class class) - putI (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.PUTFIELD $class field primitive) - - #.None - (let [$unboxed (descriptor.class unboxed)] - (|>> (_.CHECKCAST $unboxed) - (_.PUTFIELD $class field $unboxed))))]] - (wrap (|>> objectI - (_.CHECKCAST $class) - _.DUP - valueI - putI))) + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any) + (function (_ extension-name generate [class field unboxed valueS objectS]) + (do phase.monad + [valueI (generate valueS) + objectI (generate objectS) + #let [$class (type.class class (list)) + putI (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (_.PUTFIELD $class field primitive) + + #.None + (let [$unboxed (type.class unboxed (list))] + (|>> (_.CHECKCAST $unboxed) + (_.PUTFIELD $class field $unboxed))))]] + (wrap (|>> objectI + (_.CHECKCAST $class) + _.DUP + valueI + putI))))])) - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) +(template [<name> <category> <parser>] + [(def: #export <name> + (Parser (Type <category>)) + (<t>.embed <parser> <s>.text))] -(def: (generate-arg generate argS) - (-> (-> Synthesis (Operation Inst)) Synthesis - (Operation [Type Inst])) - (case argS - (^ (synthesis.tuple (list (synthesis.text argD) argS))) - (do phase.monad - [argT (phase.lift (<t>.run jvm.parse-signature argD)) - argI (generate argS)] - (wrap [argT argI])) + [var Var parser.var] + [class Class parser.class] + [value Value parser.value] + [return Return parser.return] + ) - _ - (phase.throw invalid-syntax-for-argument-generation []))) +(type: Input (Typed Synthesis)) -(def: (method-return-type description) - (-> Text (Operation Return)) - (case description - (^ (static descriptor.void)) - (phase@wrap #.None) +(def: input + (Parser Input) + (<s>.tuple (<>.and ..value <s>.any))) - _ - (|> description - (<t>.run jvm.parse-signature) - phase.lift - (phase@map (|>> #.Some))))) - -(def: (prepare-argI [type argI]) - (-> [Type Inst] Inst) - (case (jvm.class-name type) - (#.Some class-name) - (|>> argI - (_.CHECKCAST class-name)) - - #.None - argI)) - -(def: (prepare-returnI return) - (-> Return Inst) - (case return - (#.Some _) - function.identity - - #.None - (_.string synthesis.unit))) +(def: (generate-input generate [valueT valueS]) + (-> (-> Synthesis (Operation Inst)) Input + (Operation (Typed Inst))) + (do phase.monad + [valueI (generate valueS)] + (case (type.primitive? valueT) + (#.Right valueT) + (wrap [valueT valueI]) + + (#.Left valueT) + (wrap [valueT (|>> valueI + (_.CHECKCAST valueT))])))) + +(def: voidI (_.string synthesis.unit)) + +(def: (prepare-output outputT) + (-> (Type Return) Inst) + (case (type.void? outputT) + (#.Right outputT) + ..voidI + + (#.Left outputT) + function.identity)) (def: invoke::static Handler (..custom - [($_ <>.and <s>.text <s>.text <s>.text (<>.some <s>.any)) - (function (_ extension-name generate [class method unboxed argsS]) + [($_ <>.and ..class <s>.text ..return (<>.some ..input)) + (function (_ extension-name generate [class method outputT inputsTS]) (do phase.monad - [argsTI (monad.map @ (generate-arg generate) argsS) - returnT (method-return-type unboxed)] - (wrap (|>> (_.fuse (list@map ..prepare-argI argsTI)) + [inputsTI (monad.map @ (generate-input generate) inputsTS)] + (wrap (|>> (_.fuse (list@map product.right inputsTI)) (_.INVOKESTATIC class method - (descriptor.method [(list@map product.left argsTI) - returnT]) + (type.method [(list@map product.left inputsTI) + outputT + (list)]) false) - (prepare-returnI returnT)))))])) + (prepare-output outputT)))))])) (template [<name> <invoke> <interface?>] [(def: <name> Handler (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any (<>.some <s>.any)) - (function (_ extension-name generate [class method unboxed objectS argsS]) + [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input)) + (function (_ extension-name generate [class method outputT objectS inputsTS]) (do phase.monad [objectI (generate objectS) - argsTI (monad.map @ (generate-arg generate) argsS) - returnT (method-return-type unboxed)] + inputsTI (monad.map @ (generate-input generate) inputsTS)] (wrap (|>> objectI (_.CHECKCAST class) - (_.fuse (list@map ..prepare-argI argsTI)) + (_.fuse (list@map product.right inputsTI)) (<invoke> class method - (descriptor.method [(list@map product.left argsTI) - returnT]) + (type.method [(list@map product.left inputsTI) + outputT + (list)]) <interface?>) - (prepare-returnI returnT)))))]))] + (prepare-output outputT)))))]))] [invoke::virtual _.INVOKEVIRTUAL false] [invoke::special _.INVOKESPECIAL false] [invoke::interface _.INVOKEINTERFACE true] ) -(def: (invoke::constructor extension-name generate inputs) +(def: invoke::constructor Handler - (case inputs - (^ (list& (synthesis.text class) argsS)) - (do phase.monad - [argsTI (monad.map @ (generate-arg generate) argsS)] - (wrap (|>> (_.NEW class) - _.DUP - (_.fuse (list@map ..prepare-argI argsTI)) - (_.INVOKESPECIAL class "<init>" - (descriptor.method [(list@map product.left argsTI) - descriptor.void]) - false)))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) + (..custom + [($_ <>.and ..class (<>.some ..input)) + (function (_ extension-name generate [class inputsTS]) + (do phase.monad + [inputsTI (monad.map @ (generate-input generate) inputsTS)] + (wrap (|>> (_.NEW class) + _.DUP + (_.fuse (list@map product.right inputsTI)) + (_.INVOKESPECIAL class "<init>" + (type.method [(list@map product.left inputsTI) + type.void + (list)]) + false)))))])) (def: member Bundle @@ -816,68 +804,6 @@ (bundle.install "constructor" invoke::constructor)))) ))) -(def: var - (Parser Var) - <s>.text) - -(def: bound - (Parser Bound) - (<>.or (<s>.constant! ["" ">"]) - (<s>.constant! ["" "<"]))) - -(def: (class' generic) - (-> (Parser Generic) (Parser Class)) - (<s>.tuple (<>.and <s>.text (<>.some generic)))) - -(def: generic - (Parser Generic) - (<>.rec - (function (_ generic) - (let [wildcard (<>.or (<s>.constant! ["" "?"]) - (<s>.tuple (<>.and ..bound generic)))] - ($_ <>.or - ..var - wildcard - (class' generic)))))) - -(def: class - (Parser Class) - (class' ..generic)) - -(def: primitive - (Parser (Descriptor Primitive)) - ($_ <>.or - (<>.after (<s>.constant! ["" reflection.boolean]) - (<>@wrap descriptor.boolean)) - (<>.after (<s>.constant! ["" reflection.byte]) - (<>@wrap descriptor.byte)) - (<>.after (<s>.constant! ["" reflection.short]) - (<>@wrap descriptor.short)) - (<>.after (<s>.constant! ["" reflection.int]) - (<>@wrap descriptor.int)) - (<>.after (<s>.constant! ["" reflection.long]) - (<>@wrap descriptor.long)) - (<>.after (<s>.constant! ["" reflection.float]) - (<>@wrap descriptor.float)) - (<>.after (<s>.constant! ["" reflection.double]) - (<>@wrap descriptor.double)) - (<>.after (<s>.constant! ["" reflection.char]) - (<>@wrap descriptor.char)) - )) - -(def: jvm-type - (Parser Type) - (<>.rec - (function (_ jvm-type) - ($_ <>.or - ..primitive - ..generic - (<s>.tuple jvm-type))))) - -(def: constructor-arg - (Parser (Typed Synthesis)) - (<s>.tuple (<>.and ..jvm-type <s>.any))) - (def: annotation-parameter (Parser (/.Annotation-Parameter Synthesis)) (<s>.tuple (<>.and <s>.text <s>.any))) @@ -888,12 +814,7 @@ (def: argument (Parser Argument) - (<s>.tuple (<>.and <s>.text ..jvm-type))) - -(def: return - (Parser Return) - (<>.or (<s>.constant! ["" (descriptor.descriptor descriptor.void)]) - ..jvm-type)) + (<s>.tuple (<>.and <s>.text ..value))) (def: overriden-method-definition (Parser [Environment (/.Overriden-Method Synthesis)]) @@ -989,15 +910,16 @@ (#synthesis.Extension [name inputsS+]) (#synthesis.Extension [name (list@map recur inputsS+)])))) -(def: $Object (descriptor.class "java.lang.Object")) +(def: $Object (type.class "java.lang.Object" (list))) (def: (anonymous-init-method env) - (-> Environment (Descriptor Method)) - (descriptor.method [(list.repeat (list.size env) $Object) - descriptor.void])) + (-> Environment [(Signature Method) (Descriptor Method)]) + (type.method [(list.repeat (list.size env) $Object) + type.void + (list)])) -(def: (with-anonymous-init class env super-class constructor-argsI) - (-> Text Environment Class (List (Typed Inst)) Def) +(def: (with-anonymous-init class env super-class inputsTI) + (-> (Type Class) Environment (Type Class) (List (Typed Inst)) Def) (let [store-capturedI (|> env list.size list.indices @@ -1008,17 +930,18 @@ _.fuse)] (_def.method #$.Public $.noneM "<init>" (anonymous-init-method env) (|>> (_.ALOAD 0) - ((_.fuse (list@map product.right constructor-argsI))) - (_.INVOKESPECIAL (product.left super-class) + ((_.fuse (list@map product.right inputsTI))) + (_.INVOKESPECIAL super-class "<init>" - (descriptor.method [(list@map product.left constructor-argsI) - descriptor.void]) + (type.method [(list@map product.left inputsTI) + type.void + (list)]) #0) store-capturedI _.RETURN)))) (def: (anonymous-instance class env) - (-> Text Environment (Operation Inst)) + (-> (Type Class) Environment (Operation Inst)) (do phase.monad [captureI+ (monad.map @ ///reference.variable env)] (wrap (|>> (_.NEW class) @@ -1026,6 +949,34 @@ (_.fuse captureI+) (_.INVOKESPECIAL class "<init>" (anonymous-init-method env) #0))))) +(def: (returnI returnT) + (-> (Type Return) Inst) + (case (type.void? returnT) + (#.Right returnT) + _.RETURN + + (#.Left returnT) + (case (type.primitive? returnT) + (#.Left returnT) + _.ARETURN + + (#.Right returnT) + (cond (or (:: type.equivalence = type.boolean returnT) + (:: type.equivalence = type.byte returnT) + (:: type.equivalence = type.short returnT) + (:: type.equivalence = type.int returnT) + (:: type.equivalence = type.char returnT)) + _.IRETURN + + (:: type.equivalence = type.long returnT) + _.LRETURN + + (:: type.equivalence = type.float returnT) + _.FRETURN + + ## (:: type.equivalence = type.double returnT) + _.DRETURN)))) + (def: class::anonymous Handler (..custom @@ -1033,14 +984,15 @@ <s>.text ..class (<s>.tuple (<>.some ..class)) - (<s>.tuple (<>.some ..constructor-arg)) + (<s>.tuple (<>.some ..input)) (<s>.tuple (<>.some ..overriden-method-definition))) (function (_ extension-name generate [class-name super-class super-interfaces - constructor-args + inputsTS overriden-methods]) (do phase.monad - [#let [total-environment (|> overriden-methods + [#let [class (type.class class-name (list)) + total-environment (|> overriden-methods ## Get all the environments. (list@map product.left) ## Combine them. @@ -1072,12 +1024,7 @@ self-name arguments returnT exceptionsT (normalize-method-body local-mapping body)])) overriden-methods)] - constructor-argsI (monad.map @ - (function (_ [argJT argS]) - (do @ - [argG (generate argS)] - (wrap [argJT argG]))) - constructor-args) + inputsTI (monad.map @ (generate-input generate) inputsTS) method-definitions (|> normalized-methods (monad.map @ (function (_ [ownerT name strict-fp? annotations vars @@ -1090,36 +1037,10 @@ ($_ $.++M $.finalM $.strictM) $.finalM) name - (descriptor.method [(list@map product.right arguments) - returnT] - ## (list@map (|>> #jvm.Class) - ## exceptionsT) - ) - (let [returnI (case returnT - (#.Some returnT) - (case returnT - (#jvm.Primitive returnT) - (case returnT - (^or #jvm.Boolean - #jvm.Byte #jvm.Short #jvm.Int - #jvm.Char) - _.IRETURN - - #jvm.Long - _.LRETURN - - #jvm.Float - _.FRETURN - - #jvm.Double - _.DRETURN) - - _ - _.ARETURN) - - #.None - _.RETURN)] - (|>> bodyG returnI))))))) + (type.method [(list@map product.right arguments) + returnT + exceptionsT]) + (|>> bodyG (returnI returnT))))))) (:: @ map _def.fuse)) _ (generation.save! true ["" class-name] [class-name @@ -1127,9 +1048,9 @@ class-name (list) super-class super-interfaces (|>> (///function.with-environment total-environment) - (..with-anonymous-init class-name total-environment super-class constructor-argsI) + (..with-anonymous-init class total-environment super-class inputsTI) method-definitions))])] - (anonymous-instance class-name total-environment)))])) + (anonymous-instance class total-environment)))])) (def: bundle::class Bundle diff --git a/new-luxc/source/luxc/lang/translation/jvm/reference.lux b/new-luxc/source/luxc/lang/translation/jvm/reference.lux index 1995fcd74..77e98b73b 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/reference.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/reference.lux @@ -7,8 +7,7 @@ ["%" format (#+ format)]]] [target [jvm - [type - ["." descriptor]]]] + ["." type]]] [tool [compiler ["." name] @@ -36,7 +35,7 @@ (do phase.monad [function-class generation.context] (wrap (|>> (_.ALOAD 0) - (_.GETFIELD (descriptor.class function-class) + (_.GETFIELD (type.class function-class (list)) (|> variable .nat foreign-name) //.$Value))))) @@ -57,4 +56,4 @@ (-> Name (Operation Inst)) (do phase.monad [bytecode-name (generation.remember name)] - (wrap (_.GETSTATIC (descriptor.class bytecode-name) //.value-field //.$Value)))) + (wrap (_.GETSTATIC (type.class bytecode-name (list)) //.value-field //.$Value)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux index 0f3a89faf..594964be0 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux @@ -1,5 +1,5 @@ (.module: - [lux #* + [lux (#- Type) [abstract [monad (#+ do)]] [data @@ -8,8 +8,10 @@ ["." math] [target [jvm - [type - ["." descriptor (#+ Descriptor)]]]] + ["." type (#+ Type) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature)]]]] [tool [compiler [arity (#+ Arity)] @@ -24,36 +26,36 @@ ["_" inst]]]]] ["." // (#+ ByteCode)]) -(def: $Text (descriptor.class "java.lang.String")) -(def: #export $Tag descriptor.int) -(def: #export $Flag (descriptor.class "java.lang.Object")) -(def: #export $Value (descriptor.class "java.lang.Object")) -(def: #export $Index descriptor.int) -(def: #export $Stack (descriptor.array $Value)) -(def: $Throwable (descriptor.class "java.lang.Throwable")) -(def: #export $Runtime (descriptor.class "java.lang.Runtime")) +(def: $Text (type.class "java.lang.String" (list))) +(def: #export $Tag type.int) +(def: #export $Flag (type.class "java.lang.Object" (list))) +(def: #export $Value (type.class "java.lang.Object" (list))) +(def: #export $Index type.int) +(def: #export $Stack (type.array $Value)) +(def: $Throwable (type.class "java.lang.Throwable" (list))) +(def: #export $Runtime (type.class "java.lang.Runtime" (list))) (def: nullary-init-methodT - (descriptor.method [(list) descriptor.void])) + (type.method [(list) type.void (list)])) (def: throw-methodT - (descriptor.method [(list) descriptor.void])) + (type.method [(list) type.void (list)])) (def: #export logI Inst - (let [PrintStream (descriptor.class "java.io.PrintStream") - outI (_.GETSTATIC (descriptor.class "java.lang.System") "out" PrintStream) + (let [PrintStream (type.class "java.io.PrintStream" (list)) + outI (_.GETSTATIC (type.class "java.lang.System" (list)) "out" PrintStream) printI (function (_ method) - (_.INVOKEVIRTUAL PrintStream method (descriptor.method [(list $Value) descriptor.void]) #0))] + (_.INVOKEVIRTUAL PrintStream method (type.method [(list $Value) type.void (list)]) #0))] (|>> outI (_.string "LOG: ") (printI "print") outI _.SWAP (printI "println")))) (def: variant-method - (descriptor.method [(list $Tag $Flag $Value) //.$Variant])) + (type.method [(list $Tag $Flag $Value) //.$Variant (list)])) (def: #export variantI Inst - (_.INVOKESTATIC (descriptor.class //.runtime-class) "variant_make" variant-method #0)) + (_.INVOKESTATIC (type.class //.runtime-class (list)) "variant_make" variant-method #0)) (def: #export leftI Inst @@ -85,7 +87,7 @@ (<| _.with-label (function (_ @from)) _.with-label (function (_ @to)) _.with-label (function (_ @handler)) - (|>> (_.try @from @to @handler (descriptor.class "java.lang.Exception")) + (|>> (_.try @from @to @handler (type.class "java.lang.Exception" (list))) (_.label @from) unsafeI someI @@ -97,23 +99,23 @@ (def: #export string-concatI Inst - (_.INVOKEVIRTUAL $Text "concat" (descriptor.method [(list $Text) $Text]) #0)) + (_.INVOKEVIRTUAL $Text "concat" (type.method [(list $Text) $Text (list)]) #0)) (def: #export partials-field Text "partials") (def: #export apply-method Text "apply") (def: #export num-apply-variants Nat 8) (def: #export (apply-signature arity) - (-> Arity (Descriptor descriptor.Method)) - (descriptor.method [(list.repeat arity $Value) $Value])) + (-> Arity [(Signature Method) (Descriptor Method)]) + (type.method [(list.repeat arity $Value) $Value (list)])) (def: adt-methods Def - (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap descriptor.int) _.AASTORE) + (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap type.int) _.AASTORE) store-flagI (|>> _.DUP (_.int +1) (_.ALOAD 1) _.AASTORE) store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE)] (|>> ($d.method #$.Public $.staticM "variant_make" - (descriptor.method [(list $Tag $Flag $Value) //.$Variant]) + (type.method [(list $Tag $Flag $Value) //.$Variant (list)]) (|>> (_.int +3) (_.array //.$Variant) store-tagI @@ -125,11 +127,11 @@ (def: frac-methods Def - (|>> ($d.method #$.Public $.staticM "decode_frac" (descriptor.method [(list $Text) //.$Variant]) + (|>> ($d.method #$.Public $.staticM "decode_frac" (type.method [(list $Text) //.$Variant (list)]) (try-methodI (|>> (_.ALOAD 0) - (_.INVOKESTATIC (descriptor.class "java.lang.Double") "parseDouble" (descriptor.method [(list $Text) descriptor.double]) #0) - (_.wrap descriptor.double)))) + (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "parseDouble" (type.method [(list $Text) type.double (list)]) #0) + (_.wrap type.double)))) )) (def: #export popI @@ -143,11 +145,11 @@ (def: (illegal-state-exception message) (-> Text Inst) - (let [IllegalStateException (descriptor.class "java.lang.IllegalStateException")] + (let [IllegalStateException (type.class "java.lang.IllegalStateException" (list))] (|>> (_.NEW IllegalStateException) _.DUP (_.string message) - (_.INVOKESPECIAL IllegalStateException "<init>" (descriptor.method [(list $Text) descriptor.void]) #0)))) + (_.INVOKESPECIAL IllegalStateException "<init>" (type.method [(list $Text) type.void (list)]) #0)))) (def: pm-methods Def @@ -170,7 +172,7 @@ ($d.method #$.Public $.staticM "apply_fail" throw-methodT (|>> (illegal-state-exception "Error while applying function.") _.ATHROW)) - ($d.method #$.Public $.staticM "pm_push" (descriptor.method [(list $Stack $Value) $Stack]) + ($d.method #$.Public $.staticM "pm_push" (type.method [(list $Stack $Value) $Stack (list)]) (|>> (_.int +2) (_.ANEWARRAY $Stack) _.DUP @@ -182,7 +184,7 @@ (_.ALOAD 1) _.AASTORE _.ARETURN)) - ($d.method #$.Public $.staticM "pm_variant" (descriptor.method [(list //.$Variant $Tag $Flag) $Value]) + ($d.method #$.Public $.staticM "pm_variant" (type.method [(list //.$Variant $Tag $Flag) $Value (list)]) (<| _.with-label (function (_ @loop)) _.with-label (function (_ @just-return)) _.with-label (function (_ @then)) @@ -193,7 +195,7 @@ (function (_ idx) (|>> (_.int (.int idx)) _.AALOAD))) tagI (: Inst - (|>> (variant-partI 0) (_.unwrap descriptor.int))) + (|>> (variant-partI 0) (_.unwrap type.int))) flagI (variant-partI 1) datumI (variant-partI 2) shortenI (|>> (_.ALOAD 0) tagI ## Get tag @@ -234,7 +236,7 @@ (_.label @wrong) ## tag, sumT ## _.POP2 failureI))) - ($d.method #$.Public $.staticM "tuple_left" (descriptor.method [(list //.$Tuple $Index) $Value]) + ($d.method #$.Public $.staticM "tuple_left" (type.method [(list //.$Tuple $Index) $Value (list)]) (<| _.with-label (function (_ @loop)) _.with-label (function (_ @recursive)) (let [left-accessI (|>> (_.ALOAD 0) left-indexI _.AALOAD)]) @@ -245,7 +247,7 @@ (_.label @recursive) ## Recursive (recurI @loop)))) - ($d.method #$.Public $.staticM "tuple_right" (descriptor.method [(list //.$Tuple $Index) $Value]) + ($d.method #$.Public $.staticM "tuple_right" (type.method [(list //.$Tuple $Index) $Value (list)]) (<| _.with-label (function (_ @loop)) _.with-label (function (_ @not-tail)) _.with-label (function (_ @slice)) @@ -258,9 +260,10 @@ sub-rightI (|>> (_.ALOAD 0) right-indexI tuple-sizeI - (_.INVOKESTATIC (descriptor.class "java.util.Arrays") "copyOfRange" - (descriptor.method [(list //.$Tuple $Index $Index) - //.$Tuple]) + (_.INVOKESTATIC (type.class "java.util.Arrays" (list)) "copyOfRange" + (type.method [(list //.$Tuple $Index $Index) + //.$Tuple + (list)]) #0))]) (|>> (_.label @loop) last-rightI right-indexI @@ -280,8 +283,8 @@ (def: io-methods Def - (let [StringWriter (descriptor.class "java.io.StringWriter") - PrintWriter (descriptor.class "java.io.PrintWriter") + (let [StringWriter (type.class "java.io.StringWriter" (list)) + PrintWriter (type.class "java.io.PrintWriter" (list)) string-writerI (|>> (_.NEW StringWriter) _.DUP (_.INVOKESPECIAL StringWriter "<init>" nullary-init-methodT #0)) @@ -291,9 +294,9 @@ _.POP _.SWAP (_.boolean true) - (_.INVOKESPECIAL PrintWriter "<init>" (descriptor.method [(list (descriptor.class "java.io.Writer") descriptor.boolean) descriptor.void]) #0) + (_.INVOKESPECIAL PrintWriter "<init>" (type.method [(list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)]) #0) )] - (|>> ($d.method #$.Public $.staticM "try" (descriptor.method [(list //.$Function) //.$Variant]) + (|>> ($d.method #$.Public $.staticM "try" (type.method [(list //.$Function) //.$Variant (list)]) (<| _.with-label (function (_ @from)) _.with-label (function (_ @to)) _.with-label (function (_ @handler)) @@ -309,15 +312,15 @@ string-writerI ## TW _.DUP2 ## TWTW print-writerI ## TWTP - (_.INVOKEVIRTUAL $Throwable "printStackTrace" (descriptor.method [(list (descriptor.class "java.io.PrintWriter")) descriptor.void]) #0) ## TW - (_.INVOKEVIRTUAL StringWriter "toString" (descriptor.method [(list) $Text]) #0) ## TS + (_.INVOKEVIRTUAL $Throwable "printStackTrace" (type.method [(list (type.class "java.io.PrintWriter" (list))) type.void (list)]) #0) ## TW + (_.INVOKEVIRTUAL StringWriter "toString" (type.method [(list) $Text (list)]) #0) ## TS _.SWAP _.POP leftI _.ARETURN))) ))) (def: translate-runtime (Operation ByteCode) - (let [bytecode ($d.class #$.V1_6 #$.Public $.finalC //.runtime-class (list) ["java.lang.Object" (list)] (list) + (let [bytecode ($d.class #$.V1_6 #$.Public $.finalC //.runtime-class (list) (type.class "java.lang.Object" (list)) (list) (|>> adt-methods frac-methods pm-methods @@ -342,14 +345,15 @@ _.ARETURN))))) (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature 1))) $d.fuse) - bytecode ($d.abstract #$.V1_6 #$.Public $.noneC //.function-class (list) ["java.lang.Object" (list)] (list) - (|>> ($d.field #$.Public $.finalF partials-field descriptor.int) - ($d.method #$.Public $.noneM "<init>" (descriptor.method [(list descriptor.int) descriptor.void]) + $Object (type.class "java.lang.Object" (list)) + bytecode ($d.abstract #$.V1_6 #$.Public $.noneC //.function-class (list) $Object (list) + (|>> ($d.field #$.Public $.finalF partials-field type.int) + ($d.method #$.Public $.noneM "<init>" (type.method [(list type.int) type.void (list)]) (|>> (_.ALOAD 0) - (_.INVOKESPECIAL (descriptor.class "java.lang.Object") "<init>" nullary-init-methodT #0) + (_.INVOKESPECIAL $Object "<init>" nullary-init-methodT #0) (_.ALOAD 0) (_.ILOAD 1) - (_.PUTFIELD //.$Function partials-field descriptor.int) + (_.PUTFIELD //.$Function partials-field type.int) _.RETURN)) applyI))] (do phase.monad diff --git a/new-luxc/source/luxc/lang/translation/jvm/structure.lux b/new-luxc/source/luxc/lang/translation/jvm/structure.lux index e224f1f2f..81730e6bf 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/structure.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/structure.lux @@ -13,8 +13,10 @@ ["." list]]] [target [jvm - [type - ["." descriptor]]]] + ["." type (#+ Type) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature)]]]] [tool [compiler [synthesis (#+ Synthesis)] @@ -66,8 +68,9 @@ lefts))) (flagI right?) memberI - (_.INVOKESTATIC (descriptor.class //.runtime-class) + (_.INVOKESTATIC (type.class //.runtime-class (list)) "variant_make" - (descriptor.method [(list //runtime.$Tag //runtime.$Flag //runtime.$Value) - //.$Variant]) + (type.method [(list //runtime.$Tag //runtime.$Flag //runtime.$Value) + //.$Variant + (list)]) #0))))) diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux index 1311392a9..8e372f77f 100644 --- a/new-luxc/source/program.lux +++ b/new-luxc/source/program.lux @@ -92,7 +92,8 @@ (def: #export (program programI) (-> _.Inst _.Definition) - (let [nilI runtime.noneI + (let [$Object ($t.class "java.lang.Object" (list)) + nilI runtime.noneI num-inputsI (|>> ($i.ALOAD 0) $i.ARRAYLENGTH) decI (|>> ($i.int +1) $i.ISUB) headI (|>> $i.DUP @@ -103,7 +104,7 @@ $i.DUP_X2 $i.POP) pairI (|>> ($i.int +2) - ($i.ANEWARRAY "java.lang.Object") + ($i.ANEWARRAY $Object) $i.DUP_X1 $i.SWAP ($i.int +0) @@ -135,18 +136,19 @@ ($i.label @end) $i.POP ($i.ASTORE 0))) - run-ioI (|>> ($i.CHECKCAST jvm.function-class) + $Function ($t.class jvm.function-class (list)) + run-ioI (|>> ($i.CHECKCAST $Function) $i.NULL - ($i.INVOKEVIRTUAL jvm.function-class runtime.apply-method (runtime.apply-signature 1) #0)) - main-type ($t.method (list ($t.array 1 ($t.class "java.lang.String" (list)))) - #.None - (list)) + ($i.INVOKEVIRTUAL $Function runtime.apply-method (runtime.apply-signature 1) #0)) + main-type ($t.method [(list ($t.array ($t.class "java.lang.String" (list)))) + $t.void + (list)]) bytecode-name "_"] [bytecode-name ($d.class #_.V1_6 #_.Public _.finalC bytecode-name - (list) ["java.lang.Object" (list)] + (list) $Object (list) (|>> ($d.method #_.Public _.staticM "main" main-type (|>> prepare-input-listI diff --git a/stdlib/source/lux/control/parser/code.lux b/stdlib/source/lux/control/parser/code.lux index b20f707a3..5ea2247d6 100644 --- a/stdlib/source/lux/control/parser/code.lux +++ b/stdlib/source/lux/control/parser/code.lux @@ -156,17 +156,6 @@ #.Nil (#try.Success [tokens #1]) _ (#try.Success [tokens #0])))) -(def: #export (lift outcome) - (All [a] (-> (Try a) (Parser a))) - (function (_ input) - (case outcome - (#try.Failure error) - (#try.Failure error) - - (#try.Success value) - (#try.Success [input value]) - ))) - (def: #export (run syntax inputs) (All [a] (-> (Parser a) (List Code) (Try a))) (case (syntax inputs) diff --git a/stdlib/source/lux/control/parser/text.lux b/stdlib/source/lux/control/parser/text.lux index bec295f39..44d568eaf 100644 --- a/stdlib/source/lux/control/parser/text.lux +++ b/stdlib/source/lux/control/parser/text.lux @@ -345,7 +345,7 @@ {#.doc "Run a parser with the given input, instead of the real one."} (All [a] (-> Text (Parser a) (Parser a))) (function (_ real-input) - (case (run parser local-input) + (case (..run parser local-input) (#try.Failure error) (#try.Failure error) @@ -363,3 +363,12 @@ #.None (exception.throw ..cannot-slice []))))) + +(def: #export (embed structured text) + (All [s a] + (-> (Parser a) + (//.Parser s Text) + (//.Parser s a))) + (do //.monad + [raw text] + (//.lift (..run structured raw)))) diff --git a/stdlib/source/lux/control/try.lux b/stdlib/source/lux/control/try.lux index 20d4dcab7..3b27fd6a3 100644 --- a/stdlib/source/lux/control/try.lux +++ b/stdlib/source/lux/control/try.lux @@ -110,6 +110,15 @@ (#Failure message) (error! message))) +(def: #export (maybe try) + (All [a] (-> (Try a) (Maybe a))) + (case try + (#Success value) + (#.Some value) + + (#Failure message) + #.None)) + (macro: #export (default tokens compiler) {#.doc (doc "Allows you to provide a default value that will be used" "if a (Try x) value turns out to be #Failure." diff --git a/stdlib/source/lux/macro/syntax/common/reader.lux b/stdlib/source/lux/macro/syntax/common/reader.lux index bd8e3953b..02d947e47 100644 --- a/stdlib/source/lux/macro/syntax/common/reader.lux +++ b/stdlib/source/lux/macro/syntax/common/reader.lux @@ -108,7 +108,7 @@ me-definition-raw (|> definition-raw ////.expand-all (////.run compiler) - s.lift)] + p.lift)] (s.local me-definition-raw (s.form (do @ [_ (s.text! "lux def") diff --git a/stdlib/source/lux/target/jvm/reflection.lux b/stdlib/source/lux/target/jvm/reflection.lux index e6ee7e630..992ac9977 100644 --- a/stdlib/source/lux/target/jvm/reflection.lux +++ b/stdlib/source/lux/target/jvm/reflection.lux @@ -20,10 +20,13 @@ ["." dictionary]]]] ["." // #_ [encoding - ["#." name]] + ["#." name (#+ External)]] ["/" type + [category (#+ Void Value Return Method Primitive Object Class Array Parameter)] ["#." lux (#+ Mapping)] - ["." reflection]]]) + ["#." descriptor] + ["#." reflection] + ["#." parser]]]) (import: #long java/lang/String) @@ -88,7 +91,7 @@ (getConstructors [] [(java/lang/reflect/Constructor java/lang/Object)]) (getDeclaredMethods [] [java/lang/reflect/Method])) -(exception: #export (unknown-class {class Text}) +(exception: #export (unknown-class {class External}) (exception.report ["Class" (%.text class)])) @@ -103,7 +106,7 @@ ) (def: #export (load name) - (-> Text (Try (java/lang/Class java/lang/Object))) + (-> External (Try (java/lang/Class java/lang/Object))) (case (java/lang/Class::forName name) (#try.Success class) (#try.Success class) @@ -112,17 +115,63 @@ (exception.throw ..unknown-class name))) (def: #export (sub? super sub) - (-> Text Text (Try Bit)) + (-> External External (Try Bit)) (do try.monad [super (..load super) sub (..load sub)] (wrap (java/lang/Class::isAssignableFrom sub super)))) -(def: #export (generic reflection) - (-> java/lang/reflect/Type (Try /.Generic)) +(def: (class' parameter reflection) + (-> (-> java/lang/reflect/Type (Try (/.Type Parameter))) + java/lang/reflect/Type + (Try (/.Type Class))) + (<| (case (host.check java/lang/Class reflection) + (#.Some class) + (let [class-name (|> class + (:coerce (java/lang/Class java/lang/Object)) + java/lang/Class::getName)] + (`` (if (or (~~ (template [<reflection>] + [(text@= (/reflection.reflection <reflection>) + class-name)] + + [/reflection.boolean] + [/reflection.byte] + [/reflection.short] + [/reflection.int] + [/reflection.long] + [/reflection.float] + [/reflection.double] + [/reflection.char])) + (text.starts-with? /descriptor.array-prefix class-name)) + (exception.throw ..not-a-class reflection) + (#try.Success (/.class class-name (list)))))) + _) + (case (host.check java/lang/reflect/ParameterizedType reflection) + (#.Some reflection) + (let [raw (java/lang/reflect/ParameterizedType::getRawType reflection)] + (case (host.check java/lang/Class raw) + (#.Some raw) + (do try.monad + [paramsT (|> reflection + java/lang/reflect/ParameterizedType::getActualTypeArguments + array.to-list + (monad.map @ parameter))] + (wrap (/.class (|> raw + (:coerce (java/lang/Class java/lang/Object)) + java/lang/Class::getName) + paramsT))) + + _ + (exception.throw ..not-a-class raw))) + _) + ## else + (exception.throw ..cannot-convert-to-a-lux-type reflection))) + +(def: #export (parameter reflection) + (-> java/lang/reflect/Type (Try (/.Type Parameter))) (<| (case (host.check java/lang/reflect/TypeVariable reflection) (#.Some reflection) - (#try.Success (#/.Var (java/lang/reflect/TypeVariable::getName reflection))) + (#try.Success (/.var (java/lang/reflect/TypeVariable::getName reflection))) _) (case (host.check java/lang/reflect/WildcardType reflection) (#.Some reflection) @@ -136,105 +185,69 @@ (#.Some _) ## TODO: Array bounds should not be "erased" as they ## are right now. - (#try.Success (#/.Wildcard #.None)) + (#try.Success /.wildcard) _ - (:: try.monad map - (|>> [<kind>] #.Some #/.Wildcard) - (generic bound)))) - ([[_ (#.Some bound)] #/.Upper] - [[(#.Some bound) _] #/.Lower]) + (:: try.monad map <kind> (..class' parameter bound)))) + ([[_ (#.Some bound)] /.upper] + [[(#.Some bound) _] /.lower]) _ - (#try.Success (#/.Wildcard #.None))) - _) - (case (host.check java/lang/Class reflection) - (#.Some class) - (let [class-name (|> class - (:coerce (java/lang/Class java/lang/Object)) - java/lang/Class::getName)] - (case class-name - (^template [<reflection>] - (^ (static <reflection>)) - (exception.throw ..not-a-class reflection)) - ([reflection.boolean] [reflection.byte] [reflection.short] [reflection.int] - [reflection.long] [reflection.float] [reflection.double] [reflection.char]) - - _ - (if (text.starts-with? /.array-prefix class-name) - (exception.throw ..not-a-class reflection) - (#try.Success (#/.Class class-name (list)))))) + (#try.Success /.wildcard)) _) - (case (host.check java/lang/reflect/ParameterizedType reflection) - (#.Some reflection) - (let [raw (java/lang/reflect/ParameterizedType::getRawType reflection)] - (case (host.check java/lang/Class raw) - (#.Some raw) - (do try.monad - [paramsT (|> reflection - java/lang/reflect/ParameterizedType::getActualTypeArguments - array.to-list - (monad.map @ generic))] - (wrap (#/.Class (|> raw - (:coerce (java/lang/Class java/lang/Object)) - java/lang/Class::getName) - paramsT))) + (..class' parameter reflection))) - _ - (exception.throw ..not-a-class raw))) - _) - ## else - (exception.throw ..cannot-convert-to-a-lux-type reflection))) +(def: #export class + (-> java/lang/reflect/Type + (Try (/.Type Class))) + (..class' ..parameter)) (def: #export (type reflection) - (-> java/lang/reflect/Type (Try /.Type)) + (-> java/lang/reflect/Type (Try (/.Type Value))) (<| (case (host.check java/lang/Class reflection) (#.Some reflection) - (case (|> reflection - (:coerce (java/lang/Class java/lang/Object)) - java/lang/Class::getName) - (^template [<reflection> <type>] - (^ (static <reflection>)) - (#try.Success <type>)) - ([reflection.boolean /.boolean] - [reflection.byte /.byte] - [reflection.short /.short] - [reflection.int /.int] - [reflection.long /.long] - [reflection.float /.float] - [reflection.double /.double] - [reflection.char /.char]) - - class-name - (if (text.starts-with? /.array-prefix class-name) - (<t>.run /.parse-signature (|> class-name //name.internal //name.read)) - (#try.Success (/.class class-name (list))))) + (let [class-name (|> reflection + (:coerce (java/lang/Class java/lang/Object)) + java/lang/Class::getName)] + (`` (cond (~~ (template [<reflection> <type>] + [(text@= (/reflection.reflection <reflection>) + class-name) + (#try.Success <type>)] + + [/reflection.boolean /.boolean] + [/reflection.byte /.byte] + [/reflection.short /.short] + [/reflection.int /.int] + [/reflection.long /.long] + [/reflection.float /.float] + [/reflection.double /.double] + [/reflection.char /.char])) + (if (text.starts-with? /descriptor.array-prefix class-name) + (<t>.run /parser.value (|> class-name //name.internal //name.read)) + (#try.Success (/.class class-name (list))))))) _) (case (host.check java/lang/reflect/GenericArrayType reflection) (#.Some reflection) (|> reflection java/lang/reflect/GenericArrayType::getGenericComponentType type - (:: try.monad map (/.array 1))) + (:: try.monad map /.array)) _) ## else - (:: try.monad map (|>> #/.Generic) - (..generic reflection)))) + (..parameter reflection))) (def: #export (return reflection) - (-> java/lang/reflect/Type (Try /.Return)) - (with-expansions [<else> (as-is (:: try.monad map (|>> #.Some) - (..type reflection)))] + (-> java/lang/reflect/Type (Try (/.Type Return))) + (with-expansions [<else> (as-is (..type reflection))] (case (host.check java/lang/Class reflection) (#.Some class) - (case (|> class - (:coerce (java/lang/Class java/lang/Object)) - java/lang/Class::getName) - (^ (static reflection.void)) - (#try.Success #.None) - - _ - <else>) + (let [class-name (|> reflection + (:coerce (java/lang/Class java/lang/Object)) + java/lang/Class::getName)] + (if (text@= (/reflection.reflection /reflection.void) + class-name) + (#try.Success /.void) + <else>)) #.None <else>))) @@ -327,7 +340,7 @@ (template [<name> <exception> <then?> <else?>] [(def: #export (<name> field class) - (-> Text (java/lang/Class java/lang/Object) (Try [Bit /.Type])) + (-> Text (java/lang/Class java/lang/Object) (Try [Bit (/.Type Value)])) (do try.monad [fieldJ (..field field class) #let [modifiers (java/lang/reflect/Field::getModifiers fieldJ)]] diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux index d1af2ec02..d8b21a829 100644 --- a/stdlib/source/lux/target/jvm/type.lux +++ b/stdlib/source/lux/target/jvm/type.lux @@ -1,15 +1,12 @@ (.module: [lux (#- Type int char) [abstract - [equivalence (#+ Equivalence)] - [monad (#+ do)]] - [control - ["." function] - ["<>" parser ("#@." monad) - ["<t>" text (#+ Parser)]]] + [equivalence (#+ Equivalence)]] [data - ["." text ("#@." equivalence) - ["%" format (#+ format)]] + ["." maybe] + ["." text] + [number + ["n" nat]] [collection ["." list ("#@." functor)]]] [type @@ -18,7 +15,7 @@ [encoding ["#." name (#+ External)]]] ["." / #_ - [category (#+ Void Value Return Method Primitive Object Class Array Parameter)] + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] ["#." signature (#+ Signature)] ["#." descriptor (#+ Descriptor)] ["#." reflection (#+ Reflection)]]) @@ -28,6 +25,17 @@ [(Signature category) (Descriptor category) (Reflection category)] + (type: #export Argument + [Text (Type Value)]) + + (type: #export (Typed a) + [(Type Value) a]) + + (type: #export Constraint + {#name Text + #super-class (Type Class) + #super-interfaces (List (Type Class))}) + (template [<name> <style>] [(def: #export (<name> type) (All [category] (-> (Type category) (<style> category))) @@ -77,7 +85,7 @@ /reflection.wildcard])) (def: #export (var name) - (-> Text (Type Parameter)) + (-> Text (Type Var)) (:abstraction [(/signature.var name) /descriptor.var @@ -116,141 +124,43 @@ (:: /signature.equivalence = (..signature parameter) (..signature subject)))) - ) -(template [<category> <name> <signature> <type>] - [(def: <name> - (Parser (Type <category>)) - (<>.after (<t>.this (/signature.signature <signature>)) - (<>@wrap <type>)))] - - [Void void-parser /signature.void ..void] - [Primitive boolean-parser /signature.boolean ..boolean] - [Primitive byte-parser /signature.byte ..byte] - [Primitive short-parser /signature.short ..short] - [Primitive int-parser /signature.int ..int] - [Primitive long-parser /signature.long ..long] - [Primitive float-parser /signature.float ..float] - [Primitive double-parser /signature.double ..double] - [Primitive char-parser /signature.char ..char] - [Parameter wildcard-parser /signature.wildcard ..wildcard] + (def: #export (primitive? type) + (-> (Type Value) (Either (Type Object) + (Type Primitive))) + (if (`` (or (~~ (template [<type>] + [(:: ..equivalence = (: (Type Value) <type>) type)] + + [..boolean] + [..byte] + [..short] + [..int] + [..long] + [..float] + [..double] + [..char])))) + (|> type (:coerce (Type Primitive)) #.Right) + (|> type (:coerce (Type Object)) #.Left))) + + (def: #export (void? type) + (-> (Type Return) (Either (Type Value) + (Type Void))) + (if (`` (or (~~ (template [<type>] + [(:: ..equivalence = (: (Type Return) <type>) type)] + + [..void])))) + (|> type (:coerce (Type Void)) #.Right) + (|> type (:coerce (Type Value)) #.Left))) ) -(def: primitive-parser - (Parser (Type Primitive)) - ($_ <>.either - ..boolean-parser - ..byte-parser - ..short-parser - ..int-parser - ..long-parser - ..float-parser - ..double-parser - ..char-parser)) - -(def: valid-var-characters/head - (format "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "_")) - -(def: valid-var-characters/tail - (format valid-var-characters/head - "0123456789")) - -(def: valid-class-characters/head - (format valid-var-characters/head //name.internal-separator)) - -(def: valid-class-characters/tail - (format valid-var-characters/tail //name.internal-separator)) - -(template [<type> <name> <head> <tail> <adapter>] - [(def: #export <name> - (Parser <type>) - (:: <>.functor map <adapter> - (<t>.slice (<t>.and! (<t>.one-of! <head>) - (<t>.some! (<t>.one-of! <tail>))))))] - - [External class-name-parser valid-class-characters/head valid-class-characters/tail (|>> //name.internal //name.external)] - [Text var-name-parser valid-var-characters/head valid-var-characters/tail function.identity] - ) - -(def: #export var-parser - (Parser Text) - (|> ..var-name-parser - (<>.after (<t>.this /signature.var-prefix)) - (<>.before (<t>.this /descriptor.class-suffix)))) - -(def: var-parser' - (Parser (Type Parameter)) - (<>@map ..var ..var-parser)) - -(template [<name> <prefix> <constructor>] - [(def: <name> - (-> (Parser (Type Class)) (Parser (Type Parameter))) - (|>> (<>.after (<t>.this <prefix>)) - (<>@map <constructor>)))] - - [lower-parser /signature.lower-prefix ..lower] - [upper-parser /signature.upper-prefix ..upper] - ) - -(def: (class-parser parameter-parser) - (-> (Parser (Type Parameter)) (Parser (Type Class))) - (|> (do <>.monad - [_ (<t>.this /descriptor.class-prefix) - name ..class-name-parser - parameters (|> (<>.some parameter-parser) - (<>.after (<t>.this /signature.parameters-start)) - (<>.before (<t>.this /signature.parameters-end)) - (<>.default (list))) - _ (<t>.this /descriptor.class-suffix)] - (wrap (..class name parameters))) - (<>.after (<t>.this /descriptor.class-prefix)) - (<>.before (<t>.this /descriptor.class-suffix)))) - -(def: generic-parser - (Parser (Type Parameter)) - (<>.rec - (function (_ generic-parser) - (let [class-parser (..class-parser generic-parser)] - ($_ <>.either - ..var-parser' - ..wildcard-parser - (..lower-parser class-parser) - (..upper-parser class-parser) - class-parser - ))))) - -(def: array-parser - (-> (Parser (Type Value)) (Parser (Type Array))) - (|>> (<>.after (<t>.this /descriptor.array-prefix)) - (<>@map ..array))) - -(def: #export value-parser - (Parser (Type Value)) - (<>.rec - (function (_ parser) - ($_ <>.either - ..primitive-parser - ..generic-parser - (..array-parser parser) - )))) - -(def: #export method-parser - (Parser [(Signature Method) - (Descriptor Method)]) - (let [parameters-parser (: (Parser (List (Type Value))) - (|> (<>.some ..value-parser) - (<>.after (<t>.this /signature.arguments-start)) - (<>.before (<t>.this /signature.arguments-end)))) - return-parser (: (Parser (Type Return)) - (<>.either ..void-parser - ..value-parser)) - exception-parser (: (Parser (Type Class)) - (|> (..class-parser ..generic-parser) - (<>.after (<t>.this /signature.exception-prefix))))] - (do <>.monad - [parameters parameters-parser - return return-parser - exceptions (<>.some exception-parser)] - (wrap (..method [parameters return exceptions]))))) +(def: #export (class? type) + (-> (Type Value) (Maybe External)) + (let [repr (|> type ..descriptor /descriptor.descriptor)] + (if (and (text.starts-with? /descriptor.class-prefix repr) + (text.ends-with? /descriptor.class-suffix repr)) + (|> repr + (text.clip (text.size /descriptor.class-prefix) + (n.- (text.size /descriptor.class-suffix) + (text.size repr))) + (:: maybe.monad map (|>> //name.internal //name.external))) + #.None))) diff --git a/stdlib/source/lux/target/jvm/type/alias.lux b/stdlib/source/lux/target/jvm/type/alias.lux new file mode 100644 index 000000000..dfa1e4356 --- /dev/null +++ b/stdlib/source/lux/target/jvm/type/alias.lux @@ -0,0 +1,112 @@ +(.module: + [lux (#- Type int char type primitive) + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["." exception (#+ exception:)] + ["<>" parser ("#@." monad) + ["<t>" text (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + [array (#+ Array)] + ["." dictionary (#+ Dictionary)]]]] + ["." // (#+ Type) + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] + ["#." descriptor] + ["#." signature (#+ Signature)] + ["#." reflection] + ["#." parser] + ["/#" // #_ + [encoding + ["#." name]]]]) + +(type: #export Aliasing + (Dictionary Text Text)) + +(def: #export fresh + Aliasing + (dictionary.new text.hash)) + +(def: (var aliasing) + (-> Aliasing (Parser (Type Var))) + (do <>.monad + [var //parser.var'] + (wrap (|> aliasing + (dictionary.get var) + (maybe.default var) + //.var)))) + +(def: (class parameter) + (-> (Parser (Type Parameter)) (Parser (Type Class))) + (|> (do <>.monad + [_ (<t>.this //descriptor.class-prefix) + name //parser.class-name + parameters (|> (<>.some parameter) + (<>.after (<t>.this //signature.parameters-start)) + (<>.before (<t>.this //signature.parameters-end)) + (<>.default (list))) + _ (<t>.this //descriptor.class-suffix)] + (wrap (//.class name parameters))) + (<>.after (<t>.this //descriptor.class-prefix)) + (<>.before (<t>.this //descriptor.class-suffix)))) + +(template [<name> <prefix> <constructor>] + [(def: <name> + (-> (Parser (Type Class)) (Parser (Type Parameter))) + (<>.after (<t>.this <prefix>)))] + + [lower //signature.lower-prefix ..Lower] + [upper //signature.upper-prefix ..Upper] + ) + +(def: (parameter aliasing) + (-> Aliasing (Parser (Type Parameter))) + (<>.rec + (function (_ parameter) + (let [class (..class parameter)] + ($_ <>.either + (..var aliasing) + //parser.wildcard + (..lower class) + (..upper class) + class + ))))) + +(def: (value aliasing) + (-> Aliasing (Parser (Type Value))) + (<>.rec + (function (_ value) + ($_ <>.either + //parser.primitive + (parameter aliasing) + (//parser.array' value) + )))) + +(def: (return aliasing) + (-> Aliasing (Parser (Type Return))) + ($_ <>.either + //parser.void + (..value aliasing) + )) + +(def: #export (method aliasing signature) + (-> Aliasing (Signature Method) (Signature Method)) + (let [parameters (: (Parser (List (Type Value))) + (|> (<>.some (..value aliasing)) + (<>.after (<t>.this //signature.arguments-start)) + (<>.before (<t>.this //signature.arguments-end)))) + exception (: (Parser (Type Class)) + (|> (..class (..parameter aliasing)) + (<>.after (<t>.this //signature.exception-prefix))))] + (|> (//signature.signature signature) + (<t>.run (do <>.monad + [parameters parameters + return (..return aliasing) + exceptions (<>.some exception)] + (wrap (product.left (//.method [parameters return exceptions]))))) + try.assume))) diff --git a/stdlib/source/lux/target/jvm/type/box.lux b/stdlib/source/lux/target/jvm/type/box.lux index 37f160458..65816b487 100644 --- a/stdlib/source/lux/target/jvm/type/box.lux +++ b/stdlib/source/lux/target/jvm/type/box.lux @@ -1,8 +1,11 @@ (.module: - [lux (#- int char)]) + [lux (#- int char)] + [/// + [encoding + [name (#+ External)]]]) (template [<name> <box>] - [(def: #export <name> <box>)] + [(def: #export <name> External <box>)] [boolean "java.lang.Boolean"] [byte "java.lang.Byte"] diff --git a/stdlib/source/lux/target/jvm/type/category.lux b/stdlib/source/lux/target/jvm/type/category.lux index 3bbf03783..cbeaa53ef 100644 --- a/stdlib/source/lux/target/jvm/type/category.lux +++ b/stdlib/source/lux/target/jvm/type/category.lux @@ -27,6 +27,7 @@ (`` (<| Return' Value' (~~ (template.splice <parents>)) <raw>))))] [[] Primitive] + [[Object' Parameter'] Var] [[Object' Parameter'] Class] [[Object'] Array] ) diff --git a/stdlib/source/lux/target/jvm/type/descriptor.lux b/stdlib/source/lux/target/jvm/type/descriptor.lux index e16693ff4..367f3338d 100644 --- a/stdlib/source/lux/target/jvm/type/descriptor.lux +++ b/stdlib/source/lux/target/jvm/type/descriptor.lux @@ -13,10 +13,10 @@ [type abstract]] ["." // #_ - [category (#+ Void Value Return Method Primitive Object Class Array Parameter)] + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] ["/#" // #_ [encoding - ["#." name (#+ External)]]]]) + ["#." name (#+ Internal External)]]]]) (abstract: #export (Descriptor category) {} @@ -53,14 +53,14 @@ (text.enclose [..class-prefix ..class-suffix]) :abstraction)) - (template [<name>] + (template [<name> <category>] [(def: #export <name> - (Descriptor Parameter) + (Descriptor <category>) (:transmutation (..class "java.lang.Object")))] - [var] - [wildcard] + [var Var] + [wildcard Parameter] ) (def: #export (lower descriptor) @@ -97,49 +97,18 @@ (def: (= parameter subject) (text@= (:representation parameter) (:representation subject)))) - (def: #export (primitive? descriptor) - (-> (Descriptor Value) (Either (Descriptor Object) - (Descriptor Primitive))) - (if (`` (or (~~ (template [<descriptor>] - [(:: ..equivalence = <descriptor> descriptor)] - - [..boolean] - [..byte] - [..short] - [..int] - [..long] - [..float] - [..double] - [..char])))) - (|> descriptor :transmutation #.Right) - (|> descriptor :transmutation #.Left))) - - (def: binary-name (|>> ///name.internal ///name.external)) - - (def: #export (class? descriptor) - (-> (Descriptor Value) (Maybe External)) - (let [repr (:representation descriptor)] - (if (and (text.starts-with? ..class-prefix repr) - (text.ends-with? ..class-suffix repr)) - (|> repr - (text.clip (text.size ..class-prefix) - (n.- (text.size ..class-suffix) - (text.size repr))) - (:: maybe.monad map ..binary-name)) - #.None))) - (def: #export class-name - (-> (Descriptor Object) External) + (-> (Descriptor Object) Internal) (let [prefix-size (text.size ..class-prefix) suffix-size (text.size ..class-suffix)] (function (_ descriptor) (let [repr (:representation descriptor)] (if (text.starts-with? ..array-prefix repr) - repr + (///name.internal repr) (|> repr (text.clip prefix-size (n.- suffix-size (text.size repr))) - (:: maybe.monad map ..binary-name) + (:: maybe.monad map ///name.internal) maybe.assume)))))) ) diff --git a/stdlib/source/lux/target/jvm/type/lux.lux b/stdlib/source/lux/target/jvm/type/lux.lux index 06cd81ec0..56203d32b 100644 --- a/stdlib/source/lux/target/jvm/type/lux.lux +++ b/stdlib/source/lux/target/jvm/type/lux.lux @@ -1,8 +1,9 @@ (.module: - [lux (#- type) + [lux (#- int char type primitive) [abstract ["." monad (#+ do)]] [control + ["." try] ["." exception (#+ exception:)] ["<>" parser ("#@." monad) ["<t>" text (#+ Parser)]]] @@ -17,9 +18,11 @@ abstract ["." check (#+ Check) ("#@." monad)]]] ["." // + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] ["#." descriptor] ["#." signature] ["#." reflection] + ["#." parser] ["/#" // #_ [encoding ["#." name]]]]) @@ -41,62 +44,63 @@ (exception.report ["Var" (%.text var)])) -(def: void-parser +(def: void (Parser (Check Type)) - (<>.after (<t>.this (//signature.signature //signature.void)) + (<>.after //parser.void (<>@wrap (check@wrap .Any)))) -(template [<name> <signature> <reflection>] +(template [<name> <parser> <reflection>] [(def: <name> (Parser (Check Type)) - (<>.after (<t>.this (//signature.signature <signature>)) + (<>.after <parser> (<>@wrap (check@wrap (#.Primitive (//reflection.reflection <reflection>) #.Nil)))))] - [boolean-parser //signature.boolean //reflection.boolean] - [byte-parser //signature.byte //reflection.byte] - [short-parser //signature.short //reflection.short] - [int-parser //signature.int //reflection.int] - [long-parser //signature.long //reflection.long] - [float-parser //signature.float //reflection.float] - [double-parser //signature.double //reflection.double] - [char-parser //signature.char //reflection.char] + [boolean //parser.boolean //reflection.boolean] + [byte //parser.byte //reflection.byte] + [short //parser.short //reflection.short] + [int //parser.int //reflection.int] + [long //parser.long //reflection.long] + [float //parser.float //reflection.float] + [double //parser.double //reflection.double] + [char //parser.char //reflection.char] ) -(def: primitive-parser +(def: primitive (Parser (Check Type)) ($_ <>.either - ..boolean-parser - ..byte-parser - ..short-parser - ..int-parser - ..long-parser - ..float-parser - ..double-parser - ..char-parser)) - -(def: wildcard-parser + ..boolean + ..byte + ..short + ..int + ..long + ..float + ..double + ..char + )) + +(def: wildcard (Parser (Check Type)) - (<>.after (<t>.this (//signature.signature //signature.wildcard)) + (<>.after //parser.wildcard (<>@wrap (check@map product.right check.existential)))) -(def: (var-parser mapping) +(def: (var mapping) (-> Mapping (Parser (Check Type))) (do <>.monad - [var //.var-parser] - (<>@wrap (case (dictionary.get var mapping) - #.None - (check.throw ..unknown-var [var]) - - (#.Some type) - (check@wrap type))))) - -(def: (class-parser parameter-parser) + [var //parser.var'] + (wrap (case (dictionary.get var mapping) + #.None + (check.throw ..unknown-var [var]) + + (#.Some type) + (check@wrap type))))) + +(def: (class' parameter) (-> (Parser (Check Type)) (Parser (Check Type))) (|> (do <>.monad [_ (<t>.this //descriptor.class-prefix) - name //.class-name-parser - parameters (|> (<>.some parameter-parser) + name //parser.class-name + parameters (|> (<>.some parameter) (<>.after (<t>.this //signature.parameters-start)) (<>.before (<t>.this //signature.parameters-end)) (<>.default (list))) @@ -110,27 +114,33 @@ (template [<name> <prefix> <constructor>] [(def: <name> (-> (Parser (Check Type)) (Parser (Check Type))) - ## TODO: Re-enable Lower and Upper, instead of using the simplified limit. - ## (<>@map (check@map (|>> <ctor> .type))) - (<>.after (<t>.this <prefix>)))] + (|> (<>.after (<t>.this <prefix>)) + ## TODO: Re-enable Lower and Upper, instead of using the simplified limit. + ## (<>@map (check@map (|>> <ctor> .type))) + ))] - [lower-parser //signature.lower-prefix ..Lower] - [upper-parser //signature.upper-prefix ..Upper] + [lower //signature.lower-prefix ..Lower] + [upper //signature.upper-prefix ..Upper] ) -(def: (generic-parser mapping) +(def: (parameter mapping) (-> Mapping (Parser (Check Type))) (<>.rec - (function (_ generic-parser) - (let [class-parser (..class-parser generic-parser)] + (function (_ parameter) + (let [class (..class' parameter)] ($_ <>.either - (..var-parser mapping) - ..wildcard-parser - (..lower-parser class-parser) - (..upper-parser class-parser) - class-parser))))) + (..var mapping) + ..wildcard + (..lower class) + (..upper class) + class + ))))) + +(def: #export class + (-> Mapping (Parser (Check Type))) + (|>> ..parameter ..class')) -(def: array-parser +(def: array (-> (Parser (Check Type)) (Parser (Check Type))) (|>> (<>@map (check@map (function (_ elementT) (case elementT @@ -141,18 +151,28 @@ (|> elementT Array .type))))) (<>.after (<t>.this //descriptor.array-prefix)))) -(def: #export (type-parser mapping) +(def: #export (type mapping) (-> Mapping (Parser (Check Type))) (<>.rec - (function (_ type-parser) + (function (_ type) ($_ <>.either - ..primitive-parser - (generic-parser mapping) - (..array-parser type-parser))))) + ..primitive + (parameter mapping) + (..array type) + )))) -(def: #export (return-parser mapping) +(def: #export (return mapping) (-> Mapping (Parser (Check Type))) ($_ <>.either - ..void-parser - (..type-parser mapping) + ..void + (..type mapping) )) + +(def: #export (check operation input) + (All [a] (-> (Parser (Check a)) Text (Check a))) + (case (<t>.run operation input) + (#try.Success check) + check + + (#try.Failure error) + (check.fail error))) diff --git a/stdlib/source/lux/target/jvm/type/parser.lux b/stdlib/source/lux/target/jvm/type/parser.lux new file mode 100644 index 000000000..fd29e4856 --- /dev/null +++ b/stdlib/source/lux/target/jvm/type/parser.lux @@ -0,0 +1,195 @@ +(.module: + [lux (#- Type int char primitive) + [abstract + [monad (#+ do)]] + [control + ["." try] + ["." function] + ["<>" parser ("#@." monad) + ["<t>" text (#+ Parser)]]] + [data + ["." product] + [text + ["%" format (#+ format)]]]] + ["." // (#+ Type) + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] + ["#." signature (#+ Signature)] + ["#." descriptor (#+ Descriptor)] + ["#." reflection (#+ Reflection)] + ["." // #_ + [encoding + ["#." name (#+ External)]]]]) + +(template [<category> <name> <signature> <type>] + [(def: #export <name> + (Parser (Type <category>)) + (<>.after (<t>.this (//signature.signature <signature>)) + (<>@wrap <type>)))] + + [Void void //signature.void //.void] + [Primitive boolean //signature.boolean //.boolean] + [Primitive byte //signature.byte //.byte] + [Primitive short //signature.short //.short] + [Primitive int //signature.int //.int] + [Primitive long //signature.long //.long] + [Primitive float //signature.float //.float] + [Primitive double //signature.double //.double] + [Primitive char //signature.char //.char] + [Parameter wildcard //signature.wildcard //.wildcard] + ) + +(def: #export primitive + (Parser (Type Primitive)) + ($_ <>.either + ..boolean + ..byte + ..short + ..int + ..long + ..float + ..double + ..char + )) + +(def: var/head + (format "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "_")) + +(def: var/tail + (format var/head + "0123456789")) + +(def: class/head + (format var/head //name.internal-separator)) + +(def: class/tail + (format var/tail //name.internal-separator)) + +(template [<type> <name> <head> <tail> <adapter>] + [(def: #export <name> + (Parser <type>) + (:: <>.functor map <adapter> + (<t>.slice (<t>.and! (<t>.one-of! <head>) + (<t>.some! (<t>.one-of! <tail>))))))] + + [External class-name class/head class/tail (|>> //name.internal //name.external)] + [Text var-name var/head var/tail function.identity] + ) + +(def: #export var' + (Parser Text) + (|> ..var-name + (<>.after (<t>.this //signature.var-prefix)) + (<>.before (<t>.this //descriptor.class-suffix)))) + +(def: #export var + (Parser (Type Var)) + (<>@map //.var ..var')) + +(def: #export var? + (-> (Type Parameter) (Maybe Text)) + (|>> //.signature + //signature.signature + (<t>.run ..var') + try.maybe)) + +(def: #export name + (-> (Type Var) Text) + (|>> //.signature + //signature.signature + (<t>.run ..var') + try.assume)) + +(template [<name> <prefix> <constructor>] + [(def: <name> + (-> (Parser (Type Class)) (Parser (Type Parameter))) + (|>> (<>.after (<t>.this <prefix>)) + (<>@map <constructor>)))] + + [lower //signature.lower-prefix //.lower] + [upper //signature.upper-prefix //.upper] + ) + +(def: (class'' parameter) + (-> (Parser (Type Parameter)) (Parser [External (List (Type Parameter))])) + (|> (do <>.monad + [_ (<t>.this //descriptor.class-prefix) + name ..class-name + parameters (|> (<>.some parameter) + (<>.after (<t>.this //signature.parameters-start)) + (<>.before (<t>.this //signature.parameters-end)) + (<>.default (list))) + _ (<t>.this //descriptor.class-suffix)] + (wrap [name parameters])) + (<>.after (<t>.this //descriptor.class-prefix)) + (<>.before (<t>.this //descriptor.class-suffix)))) + +(def: class' + (-> (Parser (Type Parameter)) (Parser (Type Class))) + (|>> ..class'' + (:: <>.monad map (product.uncurry //.class)))) + +(def: #export parameter + (Parser (Type Parameter)) + (<>.rec + (function (_ parameter) + (let [class (..class' parameter)] + ($_ <>.either + ..var + ..wildcard + (..lower class) + (..upper class) + class + ))))) + +(def: #export array' + (-> (Parser (Type Value)) (Parser (Type Array))) + (|>> (<>.after (<t>.this //descriptor.array-prefix)) + (<>@map //.array))) + +(def: #export class + (Parser (Type Class)) + (..class' ..parameter)) + +(def: #export read-class + (-> (Type Class) [External (List (Type Parameter))]) + (|>> //.signature + //signature.signature + (<t>.run (..class'' ..parameter)) + try.assume)) + +(def: #export value + (Parser (Type Value)) + (<>.rec + (function (_ value) + ($_ <>.either + ..primitive + ..parameter + (..array' value) + )))) + +(def: #export array + (Parser (Type Array)) + (..array' ..value)) + +(def: #export return + (Parser (Type Return)) + (<>.either ..void + ..value)) + +(def: #export method + (Parser [(Signature Method) + (Descriptor Method)]) + (let [parameters (: (Parser (List (Type Value))) + (|> (<>.some ..value) + (<>.after (<t>.this //signature.arguments-start)) + (<>.before (<t>.this //signature.arguments-end)))) + exception (: (Parser (Type Class)) + (|> (..class' ..parameter) + (<>.after (<t>.this //signature.exception-prefix))))] + (do <>.monad + [parameters parameters + return ..return + exceptions (<>.some exception)] + (wrap (//.method [parameters return exceptions]))))) diff --git a/stdlib/source/lux/target/jvm/type/reflection.lux b/stdlib/source/lux/target/jvm/type/reflection.lux index 65ee1aa90..ffc26fb8b 100644 --- a/stdlib/source/lux/target/jvm/type/reflection.lux +++ b/stdlib/source/lux/target/jvm/type/reflection.lux @@ -6,7 +6,7 @@ [type abstract]] ["." // #_ - [category (#+ Void Value Return Method Primitive Object Class Array Parameter)] + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] ["#." descriptor] [// [encoding @@ -47,14 +47,14 @@ (format //descriptor.array-prefix) :abstraction)) - (template [<name>] + (template [<name> <category>] [(def: #export <name> - (Reflection Parameter) + (Reflection <category>) (:transmutation (..class "java.lang.Object")))] - [var] - [wildcard] + [var Var] + [wildcard Parameter] ) (def: #export (lower reflection) diff --git a/stdlib/source/lux/target/jvm/type/signature.lux b/stdlib/source/lux/target/jvm/type/signature.lux index 260c564db..56fb04da6 100644 --- a/stdlib/source/lux/target/jvm/type/signature.lux +++ b/stdlib/source/lux/target/jvm/type/signature.lux @@ -10,7 +10,7 @@ [type abstract]] ["." // #_ - [category (#+ Void Value Return Method Primitive Object Class Array Parameter)] + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] ["#." descriptor] ["/#" // #_ [encoding @@ -54,7 +54,7 @@ (def: #export var-prefix "T") (def: #export var - (-> Text (Signature Parameter)) + (-> Text (Signature Var)) (|>> (text.enclose [..var-prefix //descriptor.class-suffix]) :abstraction)) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux index af85ebf1c..98f09019e 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux @@ -27,10 +27,16 @@ [target ["." jvm #_ [".!" reflection] - ["#" type (#+ Var Bound Primitive Generic Class Type Argument Return Method Typed) - ("method@." method-equivalence) + [encoding + [name (#+ External)]] + ["#" type (#+ Type Argument Typed) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] ["." box] ["." reflection] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature) ("#@." equivalence)] + ["#-." parser] + ["#-." alias (#+ Aliasing)] [".T" lux (#+ Mapping)]]]]] ["." // #_ ["#." lux (#+ custom)] @@ -46,6 +52,11 @@ ["#." analysis (#+ Analysis Operation Phase Handler Bundle)] ["#." synthesis]]]]]) +(def: reflection (|>> jvm.reflection reflection.reflection)) +(def: signature (|>> jvm.signature signature.signature)) + +(def: object-class "java.lang.Object") + (def: inheritance-relationship-type-name "_jvm_inheritance") (def: #export (inheritance-relationship-type class super-class super-interfaces) (-> .Type .Type (List .Type) .Type) @@ -69,14 +80,14 @@ [String "java.lang.String"] ## Primitives - [boolean reflection.boolean] - [byte reflection.byte] - [short reflection.short] - [int reflection.int] - [long reflection.long] - [float reflection.float] - [double reflection.double] - [char reflection.char] + [boolean (reflection.reflection reflection.boolean)] + [byte (reflection.reflection reflection.byte)] + [short (reflection.reflection reflection.short)] + [int (reflection.reflection reflection.int)] + [long (reflection.reflection reflection.long)] + [float (reflection.reflection reflection.float)] + [double (reflection.reflection reflection.double)] + [char (reflection.reflection reflection.char)] ) (type: Member @@ -98,6 +109,7 @@ [non-object] [non-array] + [non-parameter] ) (template [<name>] @@ -179,7 +191,7 @@ (template [<name> <prefix> <type>] [(def: <name> Bundle - (<| (///bundle.prefix <prefix>) + (<| (///bundle.prefix (reflection.reflection <prefix>)) (|> ///bundle.empty (///bundle.install "+" (//lux.binary <type> <type> <type>)) (///bundle.install "-" (//lux.binary <type> <type> <type>)) @@ -203,7 +215,7 @@ (template [<name> <prefix> <type>] [(def: <name> Bundle - (<| (///bundle.prefix <prefix>) + (<| (///bundle.prefix (reflection.reflection <prefix>)) (|> ///bundle.empty (///bundle.install "+" (//lux.binary <type> <type> <type>)) (///bundle.install "-" (//lux.binary <type> <type> <type>)) @@ -220,7 +232,7 @@ (def: bundle::char Bundle - (<| (///bundle.prefix reflection.char) + (<| (///bundle.prefix (reflection.reflection reflection.char)) (|> ///bundle.empty (///bundle.install "=" (//lux.binary ..char ..char Bit)) (///bundle.install "<" (//lux.binary ..char ..char Bit)) @@ -228,14 +240,14 @@ (def: #export boxes (Dictionary Text Text) - (|> (list [reflection.boolean box.boolean] - [reflection.byte box.byte] - [reflection.short box.short] - [reflection.int box.int] - [reflection.long box.long] - [reflection.float box.float] - [reflection.double box.double] - [reflection.char box.char]) + (|> (list [(reflection.reflection reflection.boolean) box.boolean] + [(reflection.reflection reflection.byte) box.byte] + [(reflection.reflection reflection.short) box.short] + [(reflection.reflection reflection.int) box.int] + [(reflection.reflection reflection.long) box.long] + [(reflection.reflection reflection.float) box.float] + [(reflection.reflection reflection.double) box.double] + [(reflection.reflection reflection.char) box.char]) (dictionary.from-list text.hash))) (def: (array-type-info allow-primitives? arrayT) @@ -269,19 +281,20 @@ (////@wrap [level class])) (#.Ex _) - (////@wrap [level "java.lang.Object"]) + (////@wrap [level ..object-class]) _ (/////analysis.throw ..non-array arrayT)))) (def: (primitive-array-length-handler primitive-type) - (-> Type Handler) + (-> (Type Primitive) Handler) (function (_ extension-name analyse args) (case args (^ (list arrayC)) (do ////.monad [_ (typeA.infer ..int) - arrayA (typeA.with-type (#.Primitive (reflection.class (jvm.array 1 primitive-type)) (list)) + arrayA (typeA.with-type (#.Primitive (|> (jvm.array primitive-type) ..reflection) + (list)) (analyse arrayC))] (wrap (#/////analysis.Extension extension-name (list arrayA)))) @@ -308,14 +321,15 @@ (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: (new-primitive-array-handler primitive-type) - (-> Type Handler) + (-> (Type Primitive) Handler) (function (_ extension-name analyse args) (case args (^ (list lengthC)) (do ////.monad [lengthA (typeA.with-type ..int (analyse lengthC)) - _ (typeA.infer (#.Primitive (reflection.class (jvm.array 1 primitive-type)) (list)))] + _ (typeA.infer (#.Primitive (|> (jvm.array primitive-type) ..reflection) + (list)))] (wrap (#/////analysis.Extension extension-name (list lengthA)))) _ @@ -341,52 +355,99 @@ _ (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) +(def: (check-parameter objectT) + (-> .Type (Operation (Type Parameter))) + (case objectT + (^ (#.Primitive (static array.type-name) + (list elementT))) + (/////analysis.throw ..non-parameter objectT) + + (#.Primitive name parameters) + (`` (cond (~~ (template [<reflection>] + [(text@= (reflection.reflection <reflection>) + name) + (/////analysis.throw ..non-parameter objectT)] + + [reflection.boolean] + [reflection.byte] + [reflection.short] + [reflection.int] + [reflection.long] + [reflection.float] + [reflection.double] + [reflection.char])) + + (text.starts-with? descriptor.array-prefix name) + (/////analysis.throw ..non-parameter objectT) + + ## else + (////@wrap (jvm.class name (list))))) + + (#.Named name anonymous) + (check-parameter anonymous) + + (^template [<tag>] + (<tag> id) + (////@wrap (jvm.class ..object-class (list)))) + ([#.Var] + [#.Ex]) + + (^template [<tag>] + (<tag> env unquantified) + (check-parameter unquantified)) + ([#.UnivQ] + [#.ExQ]) + + (#.Apply inputT abstractionT) + (case (type.apply (list inputT) abstractionT) + (#.Some outputT) + (check-parameter outputT) + + #.None + (/////analysis.throw ..non-parameter objectT)) + + _ + (/////analysis.throw ..non-parameter objectT))) + (def: (check-jvm objectT) - (-> .Type (Operation Type)) + (-> .Type (Operation (Type Value))) (case objectT (#.Primitive name #.Nil) - (case name - (^ (static reflection.boolean)) (////@wrap jvm.boolean) - (^ (static reflection.byte)) (////@wrap jvm.byte) - (^ (static reflection.short)) (////@wrap jvm.short) - (^ (static reflection.int)) (////@wrap jvm.int) - (^ (static reflection.long)) (////@wrap jvm.long) - (^ (static reflection.float)) (////@wrap jvm.float) - (^ (static reflection.double)) (////@wrap jvm.double) - (^ (static reflection.char)) (////@wrap jvm.char) - _ (if (text.starts-with? jvm.array-prefix name) - (////.lift (<t>.run jvm.parse-signature name)) - (////@wrap (jvm.class name (list))))) - + (`` (cond (~~ (template [<reflection> <type>] + [(text@= (reflection.reflection <reflection>) + name) + (////@wrap <type>)] + + [reflection.boolean jvm.boolean] + [reflection.byte jvm.byte] + [reflection.short jvm.short] + [reflection.int jvm.int] + [reflection.long jvm.long] + [reflection.float jvm.float] + [reflection.double jvm.double] + [reflection.char jvm.char])) + + (text.starts-with? descriptor.array-prefix name) + (////.lift (<t>.run jvm-parser.value name)) + + ## else + (////@wrap (jvm.class name (list))))) + (^ (#.Primitive (static array.type-name) (list elementT))) (|> elementT check-jvm - (////@map (jvm.array 1))) + (////@map jvm.array)) (#.Primitive name parameters) (do ////.monad - [parameters (monad.map @ check-jvm parameters) - parameters (monad.map @ (function (_ parameter) - (case parameter - (#jvm.Generic generic) - (wrap generic) - - _ - (/////analysis.throw ..primitives-cannot-have-type-parameters name))) - parameters)] + [parameters (monad.map @ check-parameter parameters)] (////@wrap (jvm.class name parameters))) (#.Named name anonymous) (check-jvm anonymous) (^template [<tag>] - (<tag> id) - (////@wrap (jvm.class "java.lang.Object" (list)))) - ([#.Var] - [#.Ex]) - - (^template [<tag>] (<tag> env unquantified) (check-jvm unquantified)) ([#.UnivQ] @@ -401,24 +462,24 @@ (/////analysis.throw ..non-object objectT)) _ - (/////analysis.throw ..non-object objectT))) + (check-parameter objectT))) (def: (check-object objectT) - (-> .Type (Operation Text)) + (-> .Type (Operation External)) (do ////.monad - [name (:: @ map reflection.class (check-jvm objectT))] + [name (:: @ map ..reflection (check-jvm objectT))] (if (dictionary.contains? name ..boxes) (/////analysis.throw ..primitives-are-not-objects [name]) (////@wrap name)))) (def: (check-return type) - (-> .Type (Operation Text)) + (-> .Type (Operation (Type Return))) (if (is? .Any type) - (////@wrap jvm.void-descriptor) - (////@map reflection.class (check-jvm type)))) + (////@wrap jvm.void) + (check-jvm type))) (def: (read-primitive-array-handler lux-type jvm-type) - (-> .Type Type Handler) + (-> .Type (Type Primitive) Handler) (function (_ extension-name analyse args) (case args (^ (list idxC arrayC)) @@ -426,7 +487,8 @@ [_ (typeA.infer lux-type) idxA (typeA.with-type ..int (analyse idxC)) - arrayA (typeA.with-type (#.Primitive (reflection.class (jvm.array 1 jvm-type)) (list)) + arrayA (typeA.with-type (#.Primitive (|> (jvm.array jvm-type) ..reflection) + (list)) (analyse arrayC))] (wrap (#/////analysis.Extension extension-name (list idxA arrayA)))) @@ -457,8 +519,9 @@ (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) (def: (write-primitive-array-handler lux-type jvm-type) - (-> .Type Type Handler) - (let [array-type (#.Primitive (reflection.class (jvm.array 1 jvm-type)) (list))] + (-> .Type (Type Primitive) Handler) + (let [array-type (#.Primitive (|> (jvm.array jvm-type) ..reflection) + (list))] (function (_ extension-name analyse args) (case args (^ (list idxC valueC arrayC)) @@ -509,47 +572,47 @@ (|> ///bundle.empty (dictionary.merge (<| (///bundle.prefix "length") (|> ///bundle.empty - (///bundle.install reflection.boolean (primitive-array-length-handler jvm.boolean)) - (///bundle.install reflection.byte (primitive-array-length-handler jvm.byte)) - (///bundle.install reflection.short (primitive-array-length-handler jvm.short)) - (///bundle.install reflection.int (primitive-array-length-handler jvm.int)) - (///bundle.install reflection.long (primitive-array-length-handler jvm.long)) - (///bundle.install reflection.float (primitive-array-length-handler jvm.float)) - (///bundle.install reflection.double (primitive-array-length-handler jvm.double)) - (///bundle.install reflection.char (primitive-array-length-handler jvm.char)) + (///bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler jvm.char)) (///bundle.install "object" array::length::object)))) (dictionary.merge (<| (///bundle.prefix "new") (|> ///bundle.empty - (///bundle.install reflection.boolean (new-primitive-array-handler jvm.boolean)) - (///bundle.install reflection.byte (new-primitive-array-handler jvm.byte)) - (///bundle.install reflection.short (new-primitive-array-handler jvm.short)) - (///bundle.install reflection.int (new-primitive-array-handler jvm.int)) - (///bundle.install reflection.long (new-primitive-array-handler jvm.long)) - (///bundle.install reflection.float (new-primitive-array-handler jvm.float)) - (///bundle.install reflection.double (new-primitive-array-handler jvm.double)) - (///bundle.install reflection.char (new-primitive-array-handler jvm.char)) + (///bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler jvm.char)) (///bundle.install "object" array::new::object)))) (dictionary.merge (<| (///bundle.prefix "read") (|> ///bundle.empty - (///bundle.install reflection.boolean (read-primitive-array-handler ..boolean jvm.boolean)) - (///bundle.install reflection.byte (read-primitive-array-handler ..byte jvm.byte)) - (///bundle.install reflection.short (read-primitive-array-handler ..short jvm.short)) - (///bundle.install reflection.int (read-primitive-array-handler ..int jvm.int)) - (///bundle.install reflection.long (read-primitive-array-handler ..long jvm.long)) - (///bundle.install reflection.float (read-primitive-array-handler ..float jvm.float)) - (///bundle.install reflection.double (read-primitive-array-handler ..double jvm.double)) - (///bundle.install reflection.char (read-primitive-array-handler ..char jvm.char)) + (///bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler ..boolean jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler ..byte jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler ..short jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler ..int jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler ..long jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler ..float jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler ..double jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler ..char jvm.char)) (///bundle.install "object" array::read::object)))) (dictionary.merge (<| (///bundle.prefix "write") (|> ///bundle.empty - (///bundle.install reflection.boolean (write-primitive-array-handler ..boolean jvm.boolean)) - (///bundle.install reflection.byte (write-primitive-array-handler ..byte jvm.byte)) - (///bundle.install reflection.short (write-primitive-array-handler ..short jvm.short)) - (///bundle.install reflection.int (write-primitive-array-handler ..int jvm.int)) - (///bundle.install reflection.long (write-primitive-array-handler ..long jvm.long)) - (///bundle.install reflection.float (write-primitive-array-handler ..float jvm.float)) - (///bundle.install reflection.double (write-primitive-array-handler ..double jvm.double)) - (///bundle.install reflection.char (write-primitive-array-handler ..char jvm.char)) + (///bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler ..boolean jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler ..byte jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler ..short jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler ..int jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler ..long jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler ..float jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler ..double jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler ..char jvm.char)) (///bundle.install "object" array::write::object)))) ))) @@ -693,18 +756,26 @@ (getDeclaredMethods [] [java/lang/reflect/Method])) (def: (reflection-type mapping typeJ) - (-> Mapping Type (Operation .Type)) - (typeA.with-env - (luxT.type mapping typeJ))) - -(def: (reflection-return mapping return) - (-> Mapping Return (Operation .Type)) - (case return - #.None - (////@wrap .Any) - - (#.Some return) - (..reflection-type mapping return))) + (-> Mapping (Type Value) (Operation .Type)) + (case (|> typeJ jvm.signature signature.signature + (<t>.run (luxT.type mapping))) + (#try.Success check) + (typeA.with-env + check) + + (#try.Failure error) + (////.fail error))) + +(def: (reflection-return mapping typeJ) + (-> Mapping (Type Return) (Operation .Type)) + (case (|> typeJ jvm.signature signature.signature + (<t>.run (luxT.return mapping))) + (#try.Success check) + (typeA.with-env + check) + + (#try.Failure error) + (////.fail error))) (def: (class-candidate-parents from-name fromT to-name to-class) (-> Text .Type Text (java/lang/Class java/lang/Object) (Operation (List [[Text .Type] Bit]))) @@ -715,9 +786,9 @@ (function (_ superJT) (do @ [superJT (////.lift (reflection!.type superJT)) - #let [super-name (reflection.class superJT)] + #let [super-name (|> superJT ..reflection)] super-class (////.lift (reflection!.load super-name)) - superT (typeA.with-env (luxT.type mapping superJT))] + superT (reflection-type mapping superJT)] (wrap [[super-name superT] (java/lang/Class::isAssignableFrom super-class to-class)]))) (case (java/lang/Class::getGenericSuperclass from-class) (#.Some super) @@ -736,7 +807,7 @@ (monad.map ////.monad (function (_ superT) (do ////.monad - [super-name (:: @ map reflection.class (check-jvm superT)) + [super-name (:: @ map ..reflection (check-jvm superT)) super-class (////.lift (reflection!.load super-name))] (wrap [[super-name superT] (java/lang/Class::isAssignableFrom super-class to-class)]))) @@ -752,56 +823,59 @@ (^ (list fromC)) (do ////.monad [toT (///.lift macro.expected-type) - to-name (:: @ map reflection.class (check-jvm toT)) + to-name (:: @ map ..reflection (check-jvm toT)) [fromT fromA] (typeA.with-inference (analyse fromC)) - from-name (:: @ map reflection.class (check-jvm fromT)) + from-name (:: @ map ..reflection (check-jvm fromT)) can-cast? (: (Operation Bit) - (case [from-name to-name] - (^template [<primitive> <object>] - (^or (^ [(static <primitive>) (static <object>)]) - (^ [(static <object>) (static <primitive>)]) - (^ [(static <primitive>) (static <primitive>)])) - (wrap #1)) - ([reflection.boolean box.boolean] - [reflection.byte box.byte] - [reflection.short box.short] - [reflection.int box.int] - [reflection.long box.long] - [reflection.float box.float] - [reflection.double box.double] - [reflection.char box.char]) - - _ - (do @ - [_ (////.assert ..primitives-are-not-objects [from-name] - (not (dictionary.contains? from-name boxes))) - _ (////.assert ..primitives-are-not-objects [to-name] - (not (dictionary.contains? to-name boxes))) - to-class (////.lift (reflection!.load to-name)) - _ (if (text@= ..inheritance-relationship-type-name from-name) - (wrap []) - (do @ - [from-class (////.lift (reflection!.load from-name))] - (////.assert cannot-cast [fromT toT fromC] - (java/lang/Class::isAssignableFrom from-class to-class))))] - (loop [[current-name currentT] [from-name fromT]] - (if (text@= to-name current-name) - (wrap #1) - (do @ - [candidate-parents (: (Operation (List [[Text .Type] Bit])) - (if (text@= ..inheritance-relationship-type-name current-name) - (inheritance-candidate-parents currentT to-class toT fromC) - (class-candidate-parents current-name currentT to-name to-class)))] - (case (|> candidate-parents - (list.filter product.right) - (list@map product.left)) - (#.Cons [next-name nextT] _) - (recur [next-name nextT]) - - #.Nil - (/////analysis.throw cannot-cast [fromT toT fromC])) - ))))))] + (`` (cond (~~ (template [<primitive> <object>] + [(let [=primitive (reflection.reflection <primitive>)] + (or (and (text@= =primitive from-name) + (or (text@= <object> to-name) + (text@= =primitive to-name))) + (and (text@= <object> from-name) + (text@= =primitive to-name)))) + (wrap true)] + + [reflection.boolean box.boolean] + [reflection.byte box.byte] + [reflection.short box.short] + [reflection.int box.int] + [reflection.long box.long] + [reflection.float box.float] + [reflection.double box.double] + [reflection.char box.char])) + + ## else + (do @ + [_ (////.assert ..primitives-are-not-objects [from-name] + (not (dictionary.contains? from-name boxes))) + _ (////.assert ..primitives-are-not-objects [to-name] + (not (dictionary.contains? to-name boxes))) + to-class (////.lift (reflection!.load to-name)) + _ (if (text@= ..inheritance-relationship-type-name from-name) + (wrap []) + (do @ + [from-class (////.lift (reflection!.load from-name))] + (////.assert cannot-cast [fromT toT fromC] + (java/lang/Class::isAssignableFrom from-class to-class))))] + (loop [[current-name currentT] [from-name fromT]] + (if (text@= to-name current-name) + (wrap true) + (do @ + [candidate-parents (: (Operation (List [[Text .Type] Bit])) + (if (text@= ..inheritance-relationship-type-name current-name) + (inheritance-candidate-parents currentT to-class toT fromC) + (class-candidate-parents current-name currentT to-name to-class)))] + (case (|> candidate-parents + (list.filter product.right) + (list@map product.left)) + (#.Cons [next-name nextT] _) + (recur [next-name nextT]) + + #.Nil + (/////analysis.throw cannot-cast [fromT toT fromC])) + )))))))] (if can-cast? (wrap (#/////analysis.Extension extension-name (list (/////analysis.text from-name) (/////analysis.text to-name) @@ -839,7 +913,7 @@ (wrap (<| (#/////analysis.Extension extension-name) (list (/////analysis.text class) (/////analysis.text field) - (/////analysis.text (reflection.class fieldJT)))))))])) + (/////analysis.text (|> fieldJT ..reflection)))))))])) (def: static::put Handler @@ -876,8 +950,7 @@ [final? fieldJT] (reflection!.virtual-field field class) mapping (reflection!.correspond class objectT)] (wrap [mapping fieldJT]))) - fieldT (typeA.with-env - (luxT.type mapping fieldJT)) + fieldT (reflection-type mapping fieldJT) _ (typeA.infer fieldT)] (wrap (<| (#/////analysis.Extension extension-name) (list (/////analysis.text class) @@ -899,8 +972,7 @@ [final? fieldJT] (reflection!.virtual-field field class) mapping (reflection!.correspond class objectT)] (wrap [final? mapping fieldJT]))) - fieldT (typeA.with-env - (luxT.type mapping fieldJT)) + fieldT (reflection-type mapping fieldJT) _ (////.assert cannot-set-a-final-field [class field] (not final?)) valueA (typeA.with-type fieldT @@ -924,7 +996,7 @@ [parameters (|> (java/lang/reflect/Method::getGenericParameterTypes method) array.to-list (monad.map try.monad reflection!.type) - (:: try.monad map (list@map reflection.class)) + (:: try.monad map (list@map ..reflection)) ////.lift) #let [modifiers (java/lang/reflect/Method::getModifiers method) correct-class? (java/lang/Object::equals class (java/lang/reflect/Method::getDeclaringClass method)) @@ -961,7 +1033,7 @@ [parameters (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor) array.to-list (monad.map try.monad reflection!.type) - (:: try.monad map (list@map reflection.class)) + (:: try.monad map (list@map ..reflection)) ////.lift)] (wrap (and (java/lang/Object::equals class (java/lang/reflect/Constructor::getDeclaringClass constructor)) (n.= (list.size arg-classes) (list.size parameters)) @@ -1150,7 +1222,7 @@ outputJC (check-return outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) - (/////analysis.text outputJC) + (/////analysis.text (..signature outputJC)) (decorate-inputs argsT argsA))))))])) (def: invoke::virtual @@ -1171,7 +1243,7 @@ outputJC (check-return outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) - (/////analysis.text outputJC) + (/////analysis.text (..signature outputJC)) objectA (decorate-inputs argsT argsA))))))])) @@ -1187,7 +1259,7 @@ outputJC (check-return outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) - (/////analysis.text outputJC) + (/////analysis.text (..signature outputJC)) (decorate-inputs argsT argsA))))))])) (def: invoke::interface @@ -1212,7 +1284,7 @@ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class-name) (/////analysis.text method) - (/////analysis.text outputJC) + (/////analysis.text (..signature outputJC)) objectA (decorate-inputs argsT argsA))))))])) @@ -1249,54 +1321,16 @@ ))) ))) -(def: #export var - (Parser Var) - <c>.text) - -(def: bound - (Parser Bound) - (<>.or (<c>.identifier! ["" ">"]) - (<c>.identifier! ["" "<"]))) - -(def: generic - (Parser Generic) - (<>.rec - (function (_ generic) - (let [wildcard (: (Parser (Maybe [Bound Generic])) - (<>.or (<c>.identifier! ["" "?"]) - (<c>.form (<>.and ..bound generic)))) - class (: (Parser Class) - (<c>.form (<>.and <c>.text (<>.some generic))))] - ($_ <>.or - ..var - wildcard - class))))) - -(def: #export class - (Parser Class) - (<c>.form (<>.and <c>.text (<>.some ..generic)))) - -(def: primitive - (Parser Primitive) - ($_ <>.or - (<c>.identifier! ["" reflection.boolean]) - (<c>.identifier! ["" reflection.byte]) - (<c>.identifier! ["" reflection.short]) - (<c>.identifier! ["" reflection.int]) - (<c>.identifier! ["" reflection.long]) - (<c>.identifier! ["" reflection.float]) - (<c>.identifier! ["" reflection.double]) - (<c>.identifier! ["" reflection.char]) - )) - -(def: #export type - (Parser Type) - (<>.rec - (function (_ type) - ($_ <>.or - ..primitive - ..generic - (<c>.tuple type))))) +(template [<name> <category> <parser>] + [(def: #export <name> + (Parser (Type <category>)) + (<t>.embed <parser> <c>.text))] + + [var Var jvm-parser.var] + [class Class jvm-parser.class] + [type Value jvm-parser.value] + [return Return jvm-parser.return] + ) (def: #export typed (Parser (Typed Code)) @@ -1320,40 +1354,6 @@ (Parser Argument) (<c>.tuple (<>.and <c>.text ..type))) -(def: #export return - (Parser Return) - (<>.or (<c>.identifier! ["" reflection.void]) - ..type)) - -(def: (generic-analysis generic) - (-> Generic Analysis) - (case generic - (#jvm.Var var) - (/////analysis.text var) - - (#jvm.Wildcard wildcard) - (case wildcard - #.None - (/////analysis.constant ["" "?"]) - - (#.Some [bound limit]) - (/////analysis.tuple (list (case bound - #jvm.Lower - (/////analysis.constant ["" ">"]) - - #jvm.Upper - (/////analysis.constant ["" "<"])) - (generic-analysis limit)))) - - (#jvm.Class name parameters) - (/////analysis.tuple (list& (/////analysis.text name) - (list@map generic-analysis parameters))))) - -(def: (class-analysis [name parameters]) - (-> Class Analysis) - (/////analysis.tuple (list& (/////analysis.text name) - (list@map generic-analysis parameters)))) - (def: (annotation-parameter-analysis [name value]) (-> (Annotation-Parameter Analysis) Analysis) (/////analysis.tuple (list (/////analysis.text name) value))) @@ -1363,47 +1363,31 @@ (/////analysis.tuple (list& (/////analysis.text name) (list@map annotation-parameter-analysis parameters)))) -(def: var-analysis - (-> Var Analysis) - (|>> /////analysis.text)) - -(def: (type-analysis type) - (-> Type Analysis) - (case type - (#jvm.Primitive primitive) - (case primitive - #jvm.Boolean (/////analysis.constant ["" reflection.boolean]) - #jvm.Byte (/////analysis.constant ["" reflection.byte]) - #jvm.Short (/////analysis.constant ["" reflection.short]) - #jvm.Int (/////analysis.constant ["" reflection.int]) - #jvm.Long (/////analysis.constant ["" reflection.long]) - #jvm.Float (/////analysis.constant ["" reflection.float]) - #jvm.Double (/////analysis.constant ["" reflection.double]) - #jvm.Char (/////analysis.constant ["" reflection.char])) - - (#jvm.Generic generic) - (generic-analysis generic) - - (#jvm.Array type) - (/////analysis.tuple (list (type-analysis type))))) - -(def: (return-analysis return) - (-> Return Analysis) - (case return - #.None - (/////analysis.constant ["" jvm.void-descriptor]) - - (#.Some type) - (type-analysis type))) +(template [<name> <category>] + [(def: <name> + (-> (Type <category>) Analysis) + (|>> ..signature /////analysis.text))] + + [var-analysis Var] + [class-analysis Class] + [value-analysis Value] + [return-analysis Return] + ) (def: (typed-analysis [type term]) (-> (Typed Analysis) Analysis) - (/////analysis.tuple (list (type-analysis type) term))) + (/////analysis.tuple (list (value-analysis type) term))) + +(def: (argument-analysis [argument argumentJT]) + (-> Argument Analysis) + (/////analysis.tuple + (list (/////analysis.text argument) + (value-analysis argumentJT)))) (template [<name> <filter>] [(def: <name> (-> (java/lang/Class java/lang/Object) - (Try (List [Text Method]))) + (Try (List [Text (Signature Method)]))) (|>> java/lang/Class::getDeclaredMethods array.to-list <filter> @@ -1418,9 +1402,9 @@ reflection!.return) exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method) array.to-list - (monad.map @ reflection!.generic))] + (monad.map @ reflection!.class))] (wrap [(java/lang/reflect/Method::getName method) - (jvm.method inputs return exceptions)]))))))] + (product.left (jvm.method [inputs return exceptions]))]))))))] [abstract-methods (list.filter (|>> java/lang/reflect/Method::getModifiers java/lang/reflect/Modifier::isAbstract))] [methods (<|)] @@ -1430,8 +1414,8 @@ (template [<name> <methods>] [(def: <name> - (-> (List Class) (Try (List [Text Method]))) - (|>> (monad.map try.monad (|>> product.left reflection!.load)) + (-> (List (Type Class)) (Try (List [Text (Signature Method)]))) + (|>> (monad.map try.monad (|>> ..reflection reflection!.load)) (try@map (monad.map try.monad <methods>)) try@join (try@map list@join)))] @@ -1441,11 +1425,11 @@ ) (template [<name>] - [(exception: #export (<name> {methods (List [Text Method])}) + [(exception: #export (<name> {methods (List [Text (Signature Method)])}) (exception.report ["Methods" (exception.enumerate - (function (_ [name method]) - (format (%.text name) " " (jvm.method-signature method))) + (function (_ [name signature]) + (format (%.text name) " " (signature.signature signature))) methods)]))] [missing-abstract-methods] @@ -1453,10 +1437,10 @@ ) (type: #export Visibility - #PublicV - #PrivateV - #ProtectedV - #DefaultV) + #Public + #Private + #Protected + #Default) (type: #export Finality Bit) (type: #export Strictness Bit) @@ -1474,12 +1458,20 @@ (<c>.text! ..protected-tag) (<c>.text! ..default-tag))) +(def: #export (visibility-analysis visibility) + (-> Visibility Analysis) + (/////analysis.text (case visibility + #Public ..public-tag + #Private ..private-tag + #Protected ..protected-tag + #Default ..default-tag))) + (type: #export (Constructor a) [Visibility Strictness (List (Annotation a)) - (List Var) - (List Class) ## Exceptions + (List (Type Var)) + (List (Type Class)) ## Exceptions Text (List Argument) (List (Typed a)) @@ -1519,19 +1511,17 @@ annotations) super-arguments (monad.map @ (function (_ [jvmT super-argC]) (do @ - [luxT (typeA.with-env - (luxT.type mapping jvmT)) + [luxT (reflection-type mapping jvmT) super-argA (typeA.with-type luxT (analyse super-argC))] (wrap [jvmT super-argA]))) super-arguments) - arguments' (typeA.with-env - (monad.map check.monad - (function (_ [name jvmT]) - (do check.monad - [luxT (luxT.type mapping jvmT)] - (wrap [name luxT]))) - arguments)) + arguments' (monad.map @ + (function (_ [name jvmT]) + (do @ + [luxT (reflection-type mapping jvmT)] + (wrap [name luxT]))) + arguments) [scope bodyA] (|> arguments' (#.Cons [self-name selfT]) list.reverse @@ -1539,24 +1529,14 @@ (typeA.with-type .Any) /////analysis.with-scope)] (wrap (/////analysis.tuple (list (/////analysis.text ..constructor-tag) - (/////analysis.text (case visibility - #PublicV ..public-tag - #PrivateV ..private-tag - #ProtectedV ..protected-tag - #DefaultV ..default-tag)) + (visibility-analysis visibility) (/////analysis.bit strict-fp?) (/////analysis.tuple (list@map annotation-analysis annotationsA)) (/////analysis.tuple (list@map var-analysis vars)) (/////analysis.text self-name) - (/////analysis.tuple (list@map (function (_ [argument argumentJT]) - (/////analysis.tuple - (list (/////analysis.text argument) - (type-analysis argumentJT)))) - arguments)) - (/////analysis.tuple (list@map class-analysis - exceptions)) - (/////analysis.tuple (list@map typed-analysis - super-arguments)) + (/////analysis.tuple (list@map ..argument-analysis arguments)) + (/////analysis.tuple (list@map class-analysis exceptions)) + (/////analysis.tuple (list@map typed-analysis super-arguments)) (#/////analysis.Function (scope.environment scope) (/////analysis.tuple (list bodyA))) @@ -1568,11 +1548,11 @@ Finality Strictness (List (Annotation a)) - (List Var) + (List (Type Var)) Text (List Argument) - Return - (List Class) ## Exceptions + (Type Return) + (List (Type Class)) ## Exceptions a]) (def: virtual-tag "virtual") @@ -1610,15 +1590,13 @@ parameters)] (wrap [name parametersA]))) annotations) - returnT (typeA.with-env - (luxT.return mapping return)) - arguments' (typeA.with-env - (monad.map check.monad - (function (_ [name jvmT]) - (do check.monad - [luxT (luxT.type mapping jvmT)] - (wrap [name luxT]))) - arguments)) + returnT (reflection-return mapping return) + arguments' (monad.map @ + (function (_ [name jvmT]) + (do @ + [luxT (reflection-type mapping jvmT)] + (wrap [name luxT]))) + arguments) [scope bodyA] (|> arguments' (#.Cons [self-name selfT]) list.reverse @@ -1627,24 +1605,15 @@ /////analysis.with-scope)] (wrap (/////analysis.tuple (list (/////analysis.text ..virtual-tag) (/////analysis.text method-name) - (/////analysis.text (case visibility - #PublicV ..public-tag - #PrivateV ..private-tag - #ProtectedV ..protected-tag - #DefaultV ..default-tag)) + (visibility-analysis visibility) (/////analysis.bit final?) (/////analysis.bit strict-fp?) (/////analysis.tuple (list@map annotation-analysis annotationsA)) (/////analysis.tuple (list@map var-analysis vars)) (/////analysis.text self-name) - (/////analysis.tuple (list@map (function (_ [argument argumentJT]) - (/////analysis.tuple - (list (/////analysis.text argument) - (type-analysis argumentJT)))) - arguments)) + (/////analysis.tuple (list@map ..argument-analysis arguments)) (return-analysis return) - (/////analysis.tuple (list@map class-analysis - exceptions)) + (/////analysis.tuple (list@map class-analysis exceptions)) (#/////analysis.Function (scope.environment scope) (/////analysis.tuple (list bodyA))) @@ -1655,10 +1624,10 @@ Visibility Strictness (List (Annotation a)) - (List Var) - (List Class) ## Exceptions + (List (Type Var)) + (List (Type Class)) ## Exceptions (List Argument) - Return + (Type Return) a]) (def: #export static-tag "static") @@ -1694,15 +1663,13 @@ parameters)] (wrap [name parametersA]))) annotations) - returnT (typeA.with-env - (luxT.return mapping return)) - arguments' (typeA.with-env - (monad.map check.monad - (function (_ [name jvmT]) - (do check.monad - [luxT (luxT.type mapping jvmT)] - (wrap [name luxT]))) - arguments)) + returnT (reflection-return mapping return) + arguments' (monad.map @ + (function (_ [name jvmT]) + (do @ + [luxT (reflection-type mapping jvmT)] + (wrap [name luxT]))) + arguments) [scope bodyA] (|> arguments' list.reverse (list@fold scope.with-local (analyse body)) @@ -1710,19 +1677,11 @@ /////analysis.with-scope)] (wrap (/////analysis.tuple (list (/////analysis.text ..static-tag) (/////analysis.text method-name) - (/////analysis.text (case visibility - #PublicV ..public-tag - #PrivateV ..private-tag - #ProtectedV ..protected-tag - #DefaultV ..default-tag)) + (visibility-analysis visibility) (/////analysis.bit strict-fp?) (/////analysis.tuple (list@map annotation-analysis annotationsA)) (/////analysis.tuple (list@map var-analysis vars)) - (/////analysis.tuple (list@map (function (_ [argument argumentJT]) - (/////analysis.tuple - (list (/////analysis.text argument) - (type-analysis argumentJT)))) - arguments)) + (/////analysis.tuple (list@map ..argument-analysis arguments)) (return-analysis return) (/////analysis.tuple (list@map class-analysis exceptions)) @@ -1732,15 +1691,15 @@ )))))) (type: #export (Overriden-Method a) - [Class + [(Type Class) Text Bit (List (Annotation a)) - (List Var) + (List (Type Var)) Text (List Argument) - Return - (List Class) + (Type Return) + (List (Type Class)) a]) (def: #export overriden-tag "override") @@ -1778,15 +1737,13 @@ parameters)] (wrap [name parametersA]))) annotations) - returnT (typeA.with-env - (luxT.return mapping return)) - arguments' (typeA.with-env - (monad.map check.monad - (function (_ [name jvmT]) - (do check.monad - [luxT (luxT.type mapping jvmT)] - (wrap [name luxT]))) - arguments)) + returnT (reflection-return mapping return) + arguments' (monad.map @ + (function (_ [name jvmT]) + (do @ + [luxT (reflection-type mapping jvmT)] + (wrap [name luxT]))) + arguments) [scope bodyA] (|> arguments' (#.Cons [self-name selfT]) list.reverse @@ -1800,11 +1757,7 @@ (/////analysis.tuple (list@map annotation-analysis annotationsA)) (/////analysis.tuple (list@map var-analysis vars)) (/////analysis.text self-name) - (/////analysis.tuple (list@map (function (_ [argument argumentJT]) - (/////analysis.tuple - (list (/////analysis.text argument) - (type-analysis argumentJT)))) - arguments)) + (/////analysis.tuple (list@map ..argument-analysis arguments)) (return-analysis return) (/////analysis.tuple (list@map class-analysis exceptions)) @@ -1817,7 +1770,7 @@ (#Overriden-Method (Overriden-Method a))) (def: #export parameter-types - (-> (List Var) (Check (List [Var .Type]))) + (-> (List (Type Var)) (Check (List [(Type Var) .Type]))) (monad.map check.monad (function (_ parameterJ) (do check.monad @@ -1825,31 +1778,30 @@ (wrap [parameterJ parameterT]))))) (def: (mismatched-methods super-set sub-set) - (-> (List [Text Method]) (List [Text Method]) (List [Text Method])) + (-> (List [Text (Signature Method)]) (List [Text (Signature Method)]) (List [Text (Signature Method)])) (list.filter (function (_ [sub-name subJT]) (|> super-set (list.filter (function (_ [super-name superJT]) (and (text@= super-name sub-name) - (method@= superJT subJT)))) + (signature@= superJT subJT)))) list.size (n.= 1) not)) sub-set)) (exception: #export (class-parameter-mismatch {expected (List Text)} - {actual (List jvm.Generic)}) + {actual (List (Type Parameter))}) (exception.report ["Expected (amount)" (%.nat (list.size expected))] ["Expected (parameters)" (exception.enumerate %.text expected)] ["Actual (amount)" (%.nat (list.size actual))] - ["Actual (parameters)" (exception.enumerate (|>> #jvm.Generic jvm.signature) actual)])) + ["Actual (parameters)" (exception.enumerate ..signature actual)])) -(type: Renamer (Dictionary Text Text)) - -(def: (re-map-super [name actual-parameters]) - (-> Class (Operation Renamer)) +(def: (super-aliasing class) + (-> (Type Class) (Operation Aliasing)) (do ////.monad - [class (////.lift (reflection!.load name)) + [#let [[name actual-parameters] (jvm-parser.read-class class)] + class (////.lift (reflection!.load name)) #let [expected-parameters (|> (java/lang/Class::getTypeParameters class) array.to-list (list@map (|>> java/lang/reflect/TypeVariable::getName)))] @@ -1858,57 +1810,13 @@ (list.size actual-parameters)))] (wrap (|> (list.zip2 expected-parameters actual-parameters) (list@fold (function (_ [expected actual] mapping) - (case actual - (#jvm.Var actual) + (case (jvm-parser.var? actual) + (#.Some actual) (dictionary.put actual expected mapping) - _ + #.None mapping)) - (dictionary.new text.hash)))))) - -(def: (re-map-generic mapping generic) - (-> Renamer jvm.Generic jvm.Generic) - (case generic - (#jvm.Var var) - (#jvm.Var (|> mapping (dictionary.get var) (maybe.default var))) - - (#jvm.Wildcard wildcard) - (case wildcard - #.None - generic - - (#.Some [bound limit]) - (#jvm.Wildcard (#.Some [bound (re-map-generic mapping limit)]))) - - (#jvm.Class name parameters) - (#jvm.Class name (list@map (re-map-generic mapping) parameters)))) - -(def: (re-map-type mapping type) - (-> Renamer jvm.Type jvm.Type) - (case type - (#jvm.Primitive primitive) - type - - (#jvm.Generic generic) - (#jvm.Generic (re-map-generic mapping generic)) - - (#jvm.Array type) - (#jvm.Array (re-map-type mapping type)))) - -(def: (re-map-return mapping return) - (-> Renamer jvm.Return jvm.Return) - (case return - #.None - return - - (#.Some return) - (#.Some (re-map-type mapping return)))) - -(def: (re-map-method mapping [inputs output exceptions]) - (-> Renamer jvm.Method jvm.Method) - [(list@map (re-map-type mapping) inputs) - (re-map-return mapping output) - (list@map (re-map-generic mapping) exceptions)]) + jvm-alias.fresh))))) (def: class::anonymous Handler @@ -1928,7 +1836,9 @@ [parameters (typeA.with-env (..parameter-types parameters)) #let [mapping (list@fold (function (_ [parameterJ parameterT] mapping) - (dictionary.put parameterJ parameterT mapping)) + (dictionary.put (jvm-parser.name parameterJ) + parameterT + mapping)) luxT.fresh parameters)] name (///.lift (do macro.monad @@ -1938,18 +1848,17 @@ ..jvm-package-separator "anonymous-class" (%.nat id))))) super-classT (typeA.with-env - (luxT.class mapping super-class)) + (luxT.check (luxT.class mapping) (..signature super-class))) super-interfaceT+ (typeA.with-env (monad.map check.monad - (luxT.class mapping) + (|>> ..signature (luxT.check (luxT.class mapping))) super-interfaces)) #let [selfT (inheritance-relationship-type (#.Primitive name (list)) super-classT super-interfaceT+)] constructor-argsA+ (monad.map @ (function (_ [type term]) (do @ - [argT (typeA.with-env - (luxT.type mapping type)) + [argT (reflection-type mapping type) termA (typeA.with-type argT (analyse term))] (wrap [type termA]))) @@ -1962,11 +1871,12 @@ self-name arguments return exceptions body]) (do @ - [re-mapping (re-map-super parent-type)] - (wrap [method-name (re-map-method re-mapping - (jvm.method (list@map product.right arguments) - return - (list@map (|>> #jvm.Class) exceptions)))]))) + [aliasing (super-aliasing parent-type)] + (wrap [method-name (|> (jvm.method [(list@map product.right arguments) + return + exceptions]) + product.left + (jvm-alias.method aliasing))]))) methods) #let [missing-abstract-methods (mismatched-methods overriden-methods required-abstract-methods) invalid-overriden-methods (mismatched-methods available-methods overriden-methods)] @@ -1980,8 +1890,7 @@ (class-analysis super-class) (/////analysis.tuple (list@map class-analysis super-interfaces)) (/////analysis.tuple (list@map typed-analysis constructor-argsA+)) - (/////analysis.tuple methodsA)))) - ))])) + (/////analysis.tuple methodsA))))))])) (def: bundle::class Bundle diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux index 56067c845..eef4731d2 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux @@ -14,7 +14,6 @@ [text ["%" format (#+ format)]] [collection - ["." list ("#;." functor)] ["." dictionary]]] ["." macro ["." code]] @@ -152,11 +151,10 @@ [current-module (/////statement.lift-analysis (///.lift macro.current-module-name)) #let [full-name [current-module short-name]] - [_ annotationsT annotations] (evaluate! Code annotationsC) - #let [annotations (:coerce Code annotations)] [type valueT valueN value] (..definition full-name #.None valueC) + [_ annotationsT annotations] (evaluate! Code annotationsC) _ (/////statement.lift-analysis - (module.define short-name (#.Right [exported? type annotations value]))) + (module.define short-name (#.Right [exported? type (:coerce Code annotations) value]))) #let [_ (log! (format "Definition " (%.name full-name)))] _ (/////statement.lift-generation (////generation.learn full-name valueN)) |