diff --git a/(Functional Pearl) Backtracking, Interleaving, and Terminating Monad Transformers.pdf b/(Functional Pearl) Backtracking, Interleaving, and Terminating Monad Transformers.pdf new file mode 100644 index 0000000..8ca13a0 Binary files /dev/null and b/(Functional Pearl) Backtracking, Interleaving, and Terminating Monad Transformers.pdf differ diff --git a/(Universal Algebra and) Category Theory in Foundations of Computer Science - Andrzej Tarlecki.pdf b/(Universal Algebra and) Category Theory in Foundations of Computer Science - Andrzej Tarlecki.pdf new file mode 100644 index 0000000..a811519 Binary files /dev/null and b/(Universal Algebra and) Category Theory in Foundations of Computer Science - Andrzej Tarlecki.pdf differ diff --git a/.DS_Store b/.DS_Store new file mode 100644 index 0000000..de82fb5 Binary files /dev/null and b/.DS_Store differ diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..e69de29 diff --git a/A Curious Course on Coroutines and Concurrency.pdf b/A Curious Course on Coroutines and Concurrency.pdf new file mode 100644 index 0000000..6159f2f Binary files /dev/null and b/A Curious Course on Coroutines and Concurrency.pdf differ diff --git a/A Denotational Approach to Measuring Complexity in Functional Programs.pdf b/A Denotational Approach to Measuring Complexity in Functional Programs.pdf new file mode 100644 index 0000000..bde23f6 Binary files /dev/null and b/A Denotational Approach to Measuring Complexity in Functional Programs.pdf differ diff --git a/A Functional Approach to Memory-Safe Operating Systems.pdf b/A Functional Approach to Memory-Safe Operating Systems.pdf new file mode 100644 index 0000000..84c9dd1 Binary files /dev/null and b/A Functional Approach to Memory-Safe Operating Systems.pdf differ diff --git a/A Gentle Introduction to Type Classes and Relations in Coq.pdf b/A Gentle Introduction to Type Classes and Relations in Coq.pdf new file mode 100644 index 0000000..a02b45c Binary files /dev/null and b/A Gentle Introduction to Type Classes and Relations in Coq.pdf differ diff --git a/A Type Theory for Memory Allocation and Data Layout.pdf b/A Type Theory for Memory Allocation and Data Layout.pdf new file mode 100644 index 0000000..b47e41d Binary files /dev/null and b/A Type Theory for Memory Allocation and Data Layout.pdf differ diff --git a/A categorical setting for lower complexity.pdf b/A categorical setting for lower complexity.pdf new file mode 100644 index 0000000..aff5948 Binary files /dev/null and b/A categorical setting for lower complexity.pdf differ diff --git a/Adjoint Folds and Unfolds Or- Scything Through the Thicket of Morphisms.pdf b/Adjoint Folds and Unfolds Or- Scything Through the Thicket of Morphisms.pdf new file mode 100644 index 0000000..a310e01 Binary files /dev/null and b/Adjoint Folds and Unfolds Or- Scything Through the Thicket of Morphisms.pdf differ diff --git a/Adjointness in Foundations.pdf b/Adjointness in Foundations.pdf new file mode 100644 index 0000000..50eee36 Binary files /dev/null and b/Adjointness in Foundations.pdf differ diff --git a/Adjunctions - slides.pdf b/Adjunctions - slides.pdf new file mode 100644 index 0000000..ee12c93 Binary files /dev/null and b/Adjunctions - slides.pdf differ diff --git a/Algebra of Programming using Dependent Types.pdf b/Algebra of Programming using Dependent Types.pdf new file mode 100644 index 0000000..418d9e1 Binary files /dev/null and b/Algebra of Programming using Dependent Types.pdf differ diff --git a/Algebraic and Coalgebraic Methods in the Mathematics of Program Construction(LNCS2297, Springer, 2002)(ISBN 3540436138)(400s).pdf b/Algebraic and Coalgebraic Methods in the Mathematics of Program Construction(LNCS2297, Springer, 2002)(ISBN 3540436138)(400s).pdf new file mode 100644 index 0000000..0a15426 Binary files /dev/null and b/Algebraic and Coalgebraic Methods in the Mathematics of Program Construction(LNCS2297, Springer, 2002)(ISBN 3540436138)(400s).pdf differ diff --git a/Algebras, polynomials, & programs.pdf b/Algebras, polynomials, & programs.pdf new file mode 100644 index 0000000..3ac6b61 Binary files /dev/null and b/Algebras, polynomials, & programs.pdf differ diff --git a/Algorithmics.pdf b/Algorithmics.pdf new file mode 100644 index 0000000..86bb3c4 Binary files /dev/null and b/Algorithmics.pdf differ diff --git a/Algorithms_ Part I, 4th Edition.pdf b/Algorithms_ Part I, 4th Edition.pdf new file mode 100644 index 0000000..098eeee Binary files /dev/null and b/Algorithms_ Part I, 4th Edition.pdf differ diff --git a/Algorithms_ Part II, 4th Edition.pdf b/Algorithms_ Part II, 4th Edition.pdf new file mode 100644 index 0000000..837e3a3 Binary files /dev/null and b/Algorithms_ Part II, 4th Edition.pdf differ diff --git a/An Introduction to (Co)Algebras and (Co)Induction and their Application to the Semantics of Programming Languages.pdf b/An Introduction to (Co)Algebras and (Co)Induction and their Application to the Semantics of Programming Languages.pdf new file mode 100644 index 0000000..fe5101a Binary files /dev/null and b/An Introduction to (Co)Algebras and (Co)Induction and their Application to the Semantics of Programming Languages.pdf differ diff --git a/An Introduction to Topos Theory.pdf b/An Introduction to Topos Theory.pdf new file mode 100644 index 0000000..c16ed94 Binary files /dev/null and b/An Introduction to Topos Theory.pdf differ diff --git a/An Investigation of the Laws of Traversals.pdf b/An Investigation of the Laws of Traversals.pdf new file mode 100644 index 0000000..e9a46f6 Binary files /dev/null and b/An Investigation of the Laws of Traversals.pdf differ diff --git a/An algebra of scans.pdf b/An algebra of scans.pdf new file mode 100644 index 0000000..94c84bf Binary files /dev/null and b/An algebra of scans.pdf differ diff --git a/An introduction to Yoneda structures.pdf b/An introduction to Yoneda structures.pdf new file mode 100644 index 0000000..43af134 Binary files /dev/null and b/An introduction to Yoneda structures.pdf differ diff --git a/Applicative Programming with effects.pdf b/Applicative Programming with effects.pdf new file mode 100644 index 0000000..e539f34 Binary files /dev/null and b/Applicative Programming with effects.pdf differ diff --git a/Arrows and Computation - slides.pdf b/Arrows and Computation - slides.pdf new file mode 100644 index 0000000..4fbbcfb Binary files /dev/null and b/Arrows and Computation - slides.pdf differ diff --git a/Arrows are Strong Monads.pdf b/Arrows are Strong Monads.pdf new file mode 100644 index 0000000..a7b02c1 Binary files /dev/null and b/Arrows are Strong Monads.pdf differ diff --git a/Calculating Correct Compilers.pdf b/Calculating Correct Compilers.pdf new file mode 100644 index 0000000..5234a29 Binary files /dev/null and b/Calculating Correct Compilers.pdf differ diff --git a/Cartesian Closed Categories CCC - Andrzej Tarlecki.pdf b/Cartesian Closed Categories CCC - Andrzej Tarlecki.pdf new file mode 100644 index 0000000..c26ec1a Binary files /dev/null and b/Cartesian Closed Categories CCC - Andrzej Tarlecki.pdf differ diff --git a/Categorical Programming with Inductive and Coinductive Types.pdf b/Categorical Programming with Inductive and Coinductive Types.pdf new file mode 100644 index 0000000..c445224 Binary files /dev/null and b/Categorical Programming with Inductive and Coinductive Types.pdf differ diff --git a/Categorical semantics and composition of tree transducers.pdf b/Categorical semantics and composition of tree transducers.pdf new file mode 100644 index 0000000..7b5900a Binary files /dev/null and b/Categorical semantics and composition of tree transducers.pdf differ diff --git a/Categories for the working mathematician.pdf b/Categories for the working mathematician.pdf new file mode 100644 index 0000000..af59d4d Binary files /dev/null and b/Categories for the working mathematician.pdf differ diff --git a/Categorifying Computations into Components via Arrows as Profunctors.pdf b/Categorifying Computations into Components via Arrows as Profunctors.pdf new file mode 100644 index 0000000..242e865 Binary files /dev/null and b/Categorifying Computations into Components via Arrows as Profunctors.pdf differ diff --git a/Category theory for Computer Science - Andrzej Tarlecki.pdf b/Category theory for Computer Science - Andrzej Tarlecki.pdf new file mode 100644 index 0000000..f0b5408 Binary files /dev/null and b/Category theory for Computer Science - Andrzej Tarlecki.pdf differ diff --git a/Certified Programming with Dependent Types.pdf b/Certified Programming with Dependent Types.pdf new file mode 100644 index 0000000..59b962e Binary files /dev/null and b/Certified Programming with Dependent Types.pdf differ diff --git a/Comonadic Notions of Computation.pdf b/Comonadic Notions of Computation.pdf new file mode 100644 index 0000000..d7961fe Binary files /dev/null and b/Comonadic Notions of Computation.pdf differ diff --git a/Comonadic notions of computation vene-slides.pdf b/Comonadic notions of computation vene-slides.pdf new file mode 100644 index 0000000..bd99f60 Binary files /dev/null and b/Comonadic notions of computation vene-slides.pdf differ diff --git a/Comonads - Musings on Signals and Comonads.pdf b/Comonads - Musings on Signals and Comonads.pdf new file mode 100644 index 0000000..4187be9 Binary files /dev/null and b/Comonads - Musings on Signals and Comonads.pdf differ diff --git a/Compilation a la Carte.pdf b/Compilation a la Carte.pdf new file mode 100644 index 0000000..916ebfe Binary files /dev/null and b/Compilation a la Carte.pdf differ diff --git a/Composing and Decomposing Data Types A Closed Type Families Implementation of Data Types `a la Carte-slides.pdf b/Composing and Decomposing Data Types A Closed Type Families Implementation of Data Types `a la Carte-slides.pdf new file mode 100644 index 0000000..ecb157d Binary files /dev/null and b/Composing and Decomposing Data Types A Closed Type Families Implementation of Data Types `a la Carte-slides.pdf differ diff --git a/Composing and Decomposing Data Types A Closed Type Families Implementation of Data Types a` la Carte.pdf b/Composing and Decomposing Data Types A Closed Type Families Implementation of Data Types a` la Carte.pdf new file mode 100644 index 0000000..a42466a Binary files /dev/null and b/Composing and Decomposing Data Types A Closed Type Families Implementation of Data Types a` la Carte.pdf differ diff --git a/Compositional Application Architecture With Reasonably Priced Monads.pdf b/Compositional Application Architecture With Reasonably Priced Monads.pdf new file mode 100644 index 0000000..c4479b2 Binary files /dev/null and b/Compositional Application Architecture With Reasonably Priced Monads.pdf differ diff --git a/Constructing Applicative Functors.pdf b/Constructing Applicative Functors.pdf new file mode 100644 index 0000000..0636de5 Binary files /dev/null and b/Constructing Applicative Functors.pdf differ diff --git a/Constructing tournament representations: An exercise in pointwise relational programming.pdf b/Constructing tournament representations: An exercise in pointwise relational programming.pdf new file mode 100644 index 0000000..5b43e99 Binary files /dev/null and b/Constructing tournament representations: An exercise in pointwise relational programming.pdf differ diff --git a/Denotational Design from meanings to programs Conal Elliott - lambdajam-2014.pdf b/Denotational Design from meanings to programs Conal Elliott - lambdajam-2014.pdf new file mode 100644 index 0000000..ba3725d Binary files /dev/null and b/Denotational Design from meanings to programs Conal Elliott - lambdajam-2014.pdf differ diff --git a/Denotational Design from meanings to programs Conal Elliott.pdf b/Denotational Design from meanings to programs Conal Elliott.pdf new file mode 100644 index 0000000..20dd514 Binary files /dev/null and b/Denotational Design from meanings to programs Conal Elliott.pdf differ diff --git a/Denotational design with type class morphisms (extended version).pdf b/Denotational design with type class morphisms (extended version).pdf new file mode 100644 index 0000000..8a67ab2 Binary files /dev/null and b/Denotational design with type class morphisms (extended version).pdf differ diff --git a/Derivation of a Typed Functional LR Parser.pdf b/Derivation of a Typed Functional LR Parser.pdf new file mode 100644 index 0000000..1f1a191 Binary files /dev/null and b/Derivation of a Typed Functional LR Parser.pdf differ diff --git a/FUNCTIONAL PEARL Kleisli arrows of outrageous fortune - paper- .pdf b/FUNCTIONAL PEARL Kleisli arrows of outrageous fortune - paper- .pdf new file mode 100644 index 0000000..5503427 Binary files /dev/null and b/FUNCTIONAL PEARL Kleisli arrows of outrageous fortune - paper- .pdf differ diff --git a/FUNCTIONAL PEARLS [ABORTED] A trail told by an idiom.pdf b/FUNCTIONAL PEARLS [ABORTED] A trail told by an idiom.pdf new file mode 100644 index 0000000..3e17373 Binary files /dev/null and b/FUNCTIONAL PEARLS [ABORTED] A trail told by an idiom.pdf differ diff --git a/Finally Tagless, Partially Evaluated* - Tagless Staged Interpreters for Simpler Typed Languages.pdf b/Finally Tagless, Partially Evaluated* - Tagless Staged Interpreters for Simpler Typed Languages.pdf new file mode 100644 index 0000000..b854611 Binary files /dev/null and b/Finally Tagless, Partially Evaluated* - Tagless Staged Interpreters for Simpler Typed Languages.pdf differ diff --git a/Finally tagless, partially evaluated Tagless staged interpreters for simpler typed languages.pdf b/Finally tagless, partially evaluated Tagless staged interpreters for simpler typed languages.pdf new file mode 100644 index 0000000..02cd02d Binary files /dev/null and b/Finally tagless, partially evaluated Tagless staged interpreters for simpler typed languages.pdf differ diff --git a/Folding Domain-Specific Languages: Deep and Shallow Embeddings.pdf b/Folding Domain-Specific Languages: Deep and Shallow Embeddings.pdf new file mode 100644 index 0000000..3101857 Binary files /dev/null and b/Folding Domain-Specific Languages: Deep and Shallow Embeddings.pdf differ diff --git a/Free Theorems Involving Type Constructor Classes Functional Pearl.pdf b/Free Theorems Involving Type Constructor Classes Functional Pearl.pdf new file mode 100644 index 0000000..9ea8f6c Binary files /dev/null and b/Free Theorems Involving Type Constructor Classes Functional Pearl.pdf differ diff --git a/Freyd is Kleisli for Arrows - slides.pdf b/Freyd is Kleisli for Arrows - slides.pdf new file mode 100644 index 0000000..67b0d2e Binary files /dev/null and b/Freyd is Kleisli for Arrows - slides.pdf differ diff --git a/Freyd is Kleisli, for Arrows.pdf b/Freyd is Kleisli, for Arrows.pdf new file mode 100644 index 0000000..1fce0d7 Binary files /dev/null and b/Freyd is Kleisli, for Arrows.pdf differ diff --git a/Fun With Type Functions-Slides.pdf b/Fun With Type Functions-Slides.pdf new file mode 100644 index 0000000..10b8460 Binary files /dev/null and b/Fun With Type Functions-Slides.pdf differ diff --git a/Fun with Type Functions.pdf b/Fun with Type Functions.pdf new file mode 100644 index 0000000..185e818 Binary files /dev/null and b/Fun with Type Functions.pdf differ diff --git a/Functional Pearl - Be Kind Rewind Jeremy Gibbons.pdf b/Functional Pearl - Be Kind Rewind Jeremy Gibbons.pdf new file mode 100644 index 0000000..d28aabb Binary files /dev/null and b/Functional Pearl - Be Kind Rewind Jeremy Gibbons.pdf differ diff --git "a/Functional Pearl - Comprehensive Encoding of Data Types and Algorithms in the \316\273-Calculus .pdf" "b/Functional Pearl - Comprehensive Encoding of Data Types and Algorithms in the \316\273-Calculus .pdf" new file mode 100644 index 0000000..3455014 Binary files /dev/null and "b/Functional Pearl - Comprehensive Encoding of Data Types and Algorithms in the \316\273-Calculus .pdf" differ diff --git a/Functional Pearl - The Zipper.pdf b/Functional Pearl - The Zipper.pdf new file mode 100644 index 0000000..7cbdba6 Binary files /dev/null and b/Functional Pearl - The Zipper.pdf differ diff --git a/Functional Pearl A fresh look at binary search trees.pdf b/Functional Pearl A fresh look at binary search trees.pdf new file mode 100644 index 0000000..bc96f51 Binary files /dev/null and b/Functional Pearl A fresh look at binary search trees.pdf differ diff --git "a/Functional Pearl- La Tour D\342\200\231Hano \314\210\304\261.pdf" "b/Functional Pearl- La Tour D\342\200\231Hano \314\210\304\261.pdf" new file mode 100644 index 0000000..f26e84e Binary files /dev/null and "b/Functional Pearl- La Tour D\342\200\231Hano \314\210\304\261.pdf" differ diff --git a/Functional Pearl- Streams and Unique Fixed Points.pdf b/Functional Pearl- Streams and Unique Fixed Points.pdf new file mode 100644 index 0000000..d4530b8 Binary files /dev/null and b/Functional Pearl- Streams and Unique Fixed Points.pdf differ diff --git a/Functional Pearls Explaining Binomial Heaps.pdf b/Functional Pearls Explaining Binomial Heaps.pdf new file mode 100644 index 0000000..0ec0117 Binary files /dev/null and b/Functional Pearls Explaining Binomial Heaps.pdf differ diff --git "a/Functional Programming for Domain\342\210\222Specific Languages.pdf" "b/Functional Programming for Domain\342\210\222Specific Languages.pdf" new file mode 100644 index 0000000..b3cba9d Binary files /dev/null and "b/Functional Programming for Domain\342\210\222Specific Languages.pdf" differ diff --git a/Functional Programming in Scala.pdf b/Functional Programming in Scala.pdf new file mode 100644 index 0000000..b72b5b9 Binary files /dev/null and b/Functional Programming in Scala.pdf differ diff --git a/Functorial Semantics of Algebraic Theories And Some Algebraic Problems in The Context of Functorial Semantics of Algebraic Theories.pdf b/Functorial Semantics of Algebraic Theories And Some Algebraic Problems in The Context of Functorial Semantics of Algebraic Theories.pdf new file mode 100644 index 0000000..b20cc77 Binary files /dev/null and b/Functorial Semantics of Algebraic Theories And Some Algebraic Problems in The Context of Functorial Semantics of Algebraic Theories.pdf differ diff --git a/Functors and Natural Transformations - Andrzej Tarlecki.pdf b/Functors and Natural Transformations - Andrzej Tarlecki.pdf new file mode 100644 index 0000000..d79eb67 Binary files /dev/null and b/Functors and Natural Transformations - Andrzej Tarlecki.pdf differ diff --git a/Generalizing Determinization From Automata to Coalgebras.pdf b/Generalizing Determinization From Automata to Coalgebras.pdf new file mode 100644 index 0000000..405ab98 Binary files /dev/null and b/Generalizing Determinization From Automata to Coalgebras.pdf differ diff --git a/Generic Programming -An Introduction-.pdf b/Generic Programming -An Introduction-.pdf new file mode 100644 index 0000000..84776ae Binary files /dev/null and b/Generic Programming -An Introduction-.pdf differ diff --git a/Generic Programming Prim (Co)Recursion and C-o-V (Co)Iteration Categorically Slides.pdf b/Generic Programming Prim (Co)Recursion and C-o-V (Co)Iteration Categorically Slides.pdf new file mode 100644 index 0000000..d11bdcd Binary files /dev/null and b/Generic Programming Prim (Co)Recursion and C-o-V (Co)Iteration Categorically Slides.pdf differ diff --git a/Generic Programming with Adjunctions-slides.pdf b/Generic Programming with Adjunctions-slides.pdf new file mode 100644 index 0000000..60a9af5 Binary files /dev/null and b/Generic Programming with Adjunctions-slides.pdf differ diff --git a/Generic Programming with Adjunctions.pdf b/Generic Programming with Adjunctions.pdf new file mode 100644 index 0000000..b9f13be Binary files /dev/null and b/Generic Programming with Adjunctions.pdf differ diff --git a/Generic Programming with relations and functors.pdf b/Generic Programming with relations and functors.pdf new file mode 100644 index 0000000..85c7349 Binary files /dev/null and b/Generic Programming with relations and functors.pdf differ diff --git a/Generic Properies of Datatypes.pdf b/Generic Properies of Datatypes.pdf new file mode 100644 index 0000000..256562b Binary files /dev/null and b/Generic Properies of Datatypes.pdf differ diff --git a/Generic and Indexed Programming - Jeremy Gibbons.pdf b/Generic and Indexed Programming - Jeremy Gibbons.pdf new file mode 100644 index 0000000..72209e3 Binary files /dev/null and b/Generic and Indexed Programming - Jeremy Gibbons.pdf differ diff --git a/Generic and Indexed Programming.pdf b/Generic and Indexed Programming.pdf new file mode 100644 index 0000000..513c19a Binary files /dev/null and b/Generic and Indexed Programming.pdf differ diff --git a/Idris, a General Purpose Dependently Typed Programming Language: Design and Implementation.pdf b/Idris, a General Purpose Dependently Typed Programming Language: Design and Implementation.pdf new file mode 100644 index 0000000..3f3c257 Binary files /dev/null and b/Idris, a General Purpose Dependently Typed Programming Language: Design and Implementation.pdf differ diff --git a/Institutions - Andrzej Tarlecki.pdf b/Institutions - Andrzej Tarlecki.pdf new file mode 100644 index 0000000..3653014 Binary files /dev/null and b/Institutions - Andrzej Tarlecki.pdf differ diff --git a/Introduction to Category Theory, Algebras & Coalgebra.pdf b/Introduction to Category Theory, Algebras & Coalgebra.pdf new file mode 100644 index 0000000..851e9dc Binary files /dev/null and b/Introduction to Category Theory, Algebras & Coalgebra.pdf differ diff --git a/Jacobs B. Categorical Logic and Type Theory.pdf b/Jacobs B. Categorical Logic and Type Theory.pdf new file mode 100644 index 0000000..a02198d Binary files /dev/null and b/Jacobs B. Categorical Logic and Type Theory.pdf differ diff --git a/Knowledge Representation and Reasoning.pdf b/Knowledge Representation and Reasoning.pdf new file mode 100644 index 0000000..00b9272 Binary files /dev/null and b/Knowledge Representation and Reasoning.pdf differ diff --git a/Lamba Calculi with Types.pdf b/Lamba Calculi with Types.pdf new file mode 100644 index 0000000..6289f58 Binary files /dev/null and b/Lamba Calculi with Types.pdf differ diff --git a/Lambek J., Scott P.J. Introduction to Higher Order Categorical Logic.pdf b/Lambek J., Scott P.J. Introduction to Higher Order Categorical Logic.pdf new file mode 100644 index 0000000..ab415b2 Binary files /dev/null and b/Lambek J., Scott P.J. Introduction to Higher Order Categorical Logic.pdf differ diff --git a/Lecture Notes on Denotational Semantics.pdf b/Lecture Notes on Denotational Semantics.pdf new file mode 100644 index 0000000..dfb99ad Binary files /dev/null and b/Lecture Notes on Denotational Semantics.pdf differ diff --git a/Lectures on Dependent Type Theory - notes-gambino.pdf b/Lectures on Dependent Type Theory - notes-gambino.pdf new file mode 100644 index 0000000..176ae90 Binary files /dev/null and b/Lectures on Dependent Type Theory - notes-gambino.pdf differ diff --git a/Lectures on Semantics- The initial algebra and final coalgebra perspectives.pdf b/Lectures on Semantics- The initial algebra and final coalgebra perspectives.pdf new file mode 100644 index 0000000..e2e2ea3 Binary files /dev/null and b/Lectures on Semantics- The initial algebra and final coalgebra perspectives.pdf differ diff --git a/Leinster T. The Yoneda Lemma.pdf b/Leinster T. The Yoneda Lemma.pdf new file mode 100644 index 0000000..5776e98 Binary files /dev/null and b/Leinster T. The Yoneda Lemma.pdf differ diff --git a/Less Is More Generic Programming Theory and Practice.pdf b/Less Is More Generic Programming Theory and Practice.pdf new file mode 100644 index 0000000..a4d5e1d Binary files /dev/null and b/Less Is More Generic Programming Theory and Practice.pdf differ diff --git a/Logic Modelling Reasoning.pdf b/Logic Modelling Reasoning.pdf new file mode 100644 index 0000000..9f3734e Binary files /dev/null and b/Logic Modelling Reasoning.pdf differ diff --git a/Logical Specifications for Functional Programs.pdf b/Logical Specifications for Functional Programs.pdf new file mode 100644 index 0000000..75f1dbc Binary files /dev/null and b/Logical Specifications for Functional Programs.pdf differ diff --git a/Manufacturing Datatypes.pdf b/Manufacturing Datatypes.pdf new file mode 100644 index 0000000..72de43a Binary files /dev/null and b/Manufacturing Datatypes.pdf differ diff --git a/Modular Type Classes.pdf b/Modular Type Classes.pdf new file mode 100644 index 0000000..6fbe1ee Binary files /dev/null and b/Modular Type Classes.pdf differ diff --git a/Modularising inductive families.pdf b/Modularising inductive families.pdf new file mode 100644 index 0000000..8390d54 Binary files /dev/null and b/Modularising inductive families.pdf differ diff --git a/Modularity and Implementation of Mathematical Operational Semantics.pdf b/Modularity and Implementation of Mathematical Operational Semantics.pdf new file mode 100644 index 0000000..eda035a Binary files /dev/null and b/Modularity and Implementation of Mathematical Operational Semantics.pdf differ diff --git a/Monad Transformer and Modular-interpreters.pdf b/Monad Transformer and Modular-interpreters.pdf new file mode 100644 index 0000000..4342bd5 Binary files /dev/null and b/Monad Transformer and Modular-interpreters.pdf differ diff --git a/Monadic Functional Reactive Programming-talk.pdf b/Monadic Functional Reactive Programming-talk.pdf new file mode 100644 index 0000000..67ea56e Binary files /dev/null and b/Monadic Functional Reactive Programming-talk.pdf differ diff --git a/Monadic Functional Reactive Programming.pdf b/Monadic Functional Reactive Programming.pdf new file mode 100644 index 0000000..2e6c6c3 Binary files /dev/null and b/Monadic Functional Reactive Programming.pdf differ diff --git a/Monads are Trees with Grafting.pdf b/Monads are Trees with Grafting.pdf new file mode 100644 index 0000000..6333505 Binary files /dev/null and b/Monads are Trees with Grafting.pdf differ diff --git a/Monads for behaviour.pdf b/Monads for behaviour.pdf new file mode 100644 index 0000000..8a6b5f1 Binary files /dev/null and b/Monads for behaviour.pdf differ diff --git a/Monads for functional programming.pdf b/Monads for functional programming.pdf new file mode 100644 index 0000000..ad23fcd Binary files /dev/null and b/Monads for functional programming.pdf differ diff --git a/Monads for natural language semantics.pdf b/Monads for natural language semantics.pdf new file mode 100644 index 0000000..18054d7 Binary files /dev/null and b/Monads for natural language semantics.pdf differ diff --git a/Monoids- Theme and Variations (Functional Pearl).pdf b/Monoids- Theme and Variations (Functional Pearl).pdf new file mode 100644 index 0000000..17d3bc8 Binary files /dev/null and b/Monoids- Theme and Variations (Functional Pearl).pdf differ diff --git a/Notes on Universes in Type Theory.pdf b/Notes on Universes in Type Theory.pdf new file mode 100644 index 0000000..fcd168c Binary files /dev/null and b/Notes on Universes in Type Theory.pdf differ diff --git "a/Notes on \342\200\234Algebra of Programming\342\200\235 .pdf" "b/Notes on \342\200\234Algebra of Programming\342\200\235 .pdf" new file mode 100644 index 0000000..da1aa77 Binary files /dev/null and "b/Notes on \342\200\234Algebra of Programming\342\200\235 .pdf" differ diff --git a/Notions of computation and monads.pdf b/Notions of computation and monads.pdf new file mode 100644 index 0000000..a468162 Binary files /dev/null and b/Notions of computation and monads.pdf differ diff --git a/On Understanding Types, Data Abstraction, and Polymorphism.pdf b/On Understanding Types, Data Abstraction, and Polymorphism.pdf new file mode 100644 index 0000000..a5ad04e Binary files /dev/null and b/On Understanding Types, Data Abstraction, and Polymorphism.pdf differ diff --git a/Packet Guide to Core Network Protocols.pdf b/Packet Guide to Core Network Protocols.pdf new file mode 100644 index 0000000..046c454 Binary files /dev/null and b/Packet Guide to Core Network Protocols.pdf differ diff --git a/Parametric Compositional Data Types-slides (full).pdf b/Parametric Compositional Data Types-slides (full).pdf new file mode 100644 index 0000000..b6180ea Binary files /dev/null and b/Parametric Compositional Data Types-slides (full).pdf differ diff --git a/Parametric Compositional Data Types.pdf b/Parametric Compositional Data Types.pdf new file mode 100644 index 0000000..2887199 Binary files /dev/null and b/Parametric Compositional Data Types.pdf differ diff --git a/Per Martin-Lof On the Meanings of the Logical Constants & THE Justification of the Logical Laws.pdf b/Per Martin-Lof On the Meanings of the Logical Constants & THE Justification of the Logical Laws.pdf new file mode 100644 index 0000000..4c3ea2d Binary files /dev/null and b/Per Martin-Lof On the Meanings of the Logical Constants & THE Justification of the Logical Laws.pdf differ diff --git a/Program Semantics & Verification-intro.pdf b/Program Semantics & Verification-intro.pdf new file mode 100644 index 0000000..c161b09 Binary files /dev/null and b/Program Semantics & Verification-intro.pdf differ diff --git "a/Program Semantics & Verification-\357\277\274Working example-tiny.pdf" "b/Program Semantics & Verification-\357\277\274Working example-tiny.pdf" new file mode 100644 index 0000000..00e0fd3 Binary files /dev/null and "b/Program Semantics & Verification-\357\277\274Working example-tiny.pdf" differ diff --git a/Programming and Reasoning with Algebraic Effects and Dependent Types.pdf b/Programming and Reasoning with Algebraic Effects and Dependent Types.pdf new file mode 100644 index 0000000..1ea9444 Binary files /dev/null and b/Programming and Reasoning with Algebraic Effects and Dependent Types.pdf differ diff --git a/Programming and Reasoning with Side-Effects in IDRIS.pdf b/Programming and Reasoning with Side-Effects in IDRIS.pdf new file mode 100644 index 0000000..793e9b5 Binary files /dev/null and b/Programming and Reasoning with Side-Effects in IDRIS.pdf differ diff --git a/Programming in IDRIS: A Tutorial.pdf b/Programming in IDRIS: A Tutorial.pdf new file mode 100644 index 0000000..ecc32ba Binary files /dev/null and b/Programming in IDRIS: A Tutorial.pdf differ diff --git a/Programming with Arrows.pdf b/Programming with Arrows.pdf new file mode 100644 index 0000000..9811505 Binary files /dev/null and b/Programming with Arrows.pdf differ diff --git a/Proofs and Types.pdf b/Proofs and Types.pdf new file mode 100644 index 0000000..63f80d9 Binary files /dev/null and b/Proofs and Types.pdf differ diff --git a/Push-Pull Functional Reactive Programming-slides.pdf b/Push-Pull Functional Reactive Programming-slides.pdf new file mode 100644 index 0000000..df9d8c0 Binary files /dev/null and b/Push-Pull Functional Reactive Programming-slides.pdf differ diff --git a/Push-Pull Functional Reactive Programming.pdf b/Push-Pull Functional Reactive Programming.pdf new file mode 100644 index 0000000..8c1a6d7 Binary files /dev/null and b/Push-Pull Functional Reactive Programming.pdf differ diff --git a/Quantifiers and Sheaves.pdf b/Quantifiers and Sheaves.pdf new file mode 100644 index 0000000..5f1a907 Binary files /dev/null and b/Quantifiers and Sheaves.pdf differ diff --git a/Real World Haskell - Oreilly.pdf b/Real World Haskell - Oreilly.pdf new file mode 100755 index 0000000..d583c71 Binary files /dev/null and b/Real World Haskell - Oreilly.pdf differ diff --git a/Real World OCaml.pdf b/Real World OCaml.pdf new file mode 100644 index 0000000..19c46a3 Binary files /dev/null and b/Real World OCaml.pdf differ diff --git a/Reason Isomorphically!.pdf b/Reason Isomorphically!.pdf new file mode 100644 index 0000000..cc5fc64 Binary files /dev/null and b/Reason Isomorphically!.pdf differ diff --git a/Reasoning About Effects: Seeing the Wood Through the Trees (Extended Version).pdf b/Reasoning About Effects: Seeing the Wood Through the Trees (Extended Version).pdf new file mode 100644 index 0000000..48a5911 Binary files /dev/null and b/Reasoning About Effects: Seeing the Wood Through the Trees (Extended Version).pdf differ diff --git a/Recursive Coalgebras from Comonads.pdf b/Recursive Coalgebras from Comonads.pdf new file mode 100644 index 0000000..fa38c06 Binary files /dev/null and b/Recursive Coalgebras from Comonads.pdf differ diff --git a/SQL and Relational Theory, 2nd Edition.pdf b/SQL and Relational Theory, 2nd Edition.pdf new file mode 100644 index 0000000..122fd21 Binary files /dev/null and b/SQL and Relational Theory, 2nd Edition.pdf differ diff --git a/Semantics-Driven DSL Design.pdf b/Semantics-Driven DSL Design.pdf new file mode 100644 index 0000000..da654a6 Binary files /dev/null and b/Semantics-Driven DSL Design.pdf differ diff --git a/Sheaf Semantics for Physicaly Motivated Network Description with Applications.pdf b/Sheaf Semantics for Physicaly Motivated Network Description with Applications.pdf new file mode 100644 index 0000000..bc63b88 Binary files /dev/null and b/Sheaf Semantics for Physicaly Motivated Network Description with Applications.pdf differ diff --git a/Sheaves, Objects and Distributed Systems.pdf b/Sheaves, Objects and Distributed Systems.pdf new file mode 100644 index 0000000..0dd565e Binary files /dev/null and b/Sheaves, Objects and Distributed Systems.pdf differ diff --git a/Simply efficient functional reactivity.pdf b/Simply efficient functional reactivity.pdf new file mode 100644 index 0000000..cfd4c57 Binary files /dev/null and b/Simply efficient functional reactivity.pdf differ diff --git a/Sites & Sheaves.pdf b/Sites & Sheaves.pdf new file mode 100644 index 0000000..a2a48a8 Binary files /dev/null and b/Sites & Sheaves.pdf differ diff --git a/SlicingIt.pdf b/SlicingIt.pdf new file mode 100644 index 0000000..e283b84 Binary files /dev/null and b/SlicingIt.pdf differ diff --git a/Squiggoling with Bialgebras Recursion Schemes from Comonads Revisited.pdf b/Squiggoling with Bialgebras Recursion Schemes from Comonads Revisited.pdf new file mode 100644 index 0000000..aa82561 Binary files /dev/null and b/Squiggoling with Bialgebras Recursion Schemes from Comonads Revisited.pdf differ diff --git a/Strongly Typed Heterogeneous Collections.pdf b/Strongly Typed Heterogeneous Collections.pdf new file mode 100644 index 0000000..00d0d41 Binary files /dev/null and b/Strongly Typed Heterogeneous Collections.pdf differ diff --git a/StructuredProgrammingGADT.pdf b/StructuredProgrammingGADT.pdf new file mode 100644 index 0000000..73ae801 Binary files /dev/null and b/StructuredProgrammingGADT.pdf differ diff --git a/Sum of product data types ocaml-data.pdf b/Sum of product data types ocaml-data.pdf new file mode 100644 index 0000000..df52ba4 Binary files /dev/null and b/Sum of product data types ocaml-data.pdf differ diff --git a/THEORETICAL PEARL - Church numerals, twice!.pdf b/THEORETICAL PEARL - Church numerals, twice!.pdf new file mode 100644 index 0000000..c4a739e Binary files /dev/null and b/THEORETICAL PEARL - Church numerals, twice!.pdf differ diff --git a/The Derivative of a Regular Type is its Type of One-Hole Contexts.pdf b/The Derivative of a Regular Type is its Type of One-Hole Contexts.pdf new file mode 100644 index 0000000..4d63bfc Binary files /dev/null and b/The Derivative of a Regular Type is its Type of One-Hole Contexts.pdf differ diff --git a/The Java Virtual Machine Specification Java SE 8 Edition.pdf b/The Java Virtual Machine Specification Java SE 8 Edition.pdf new file mode 100644 index 0000000..4e5a9ff Binary files /dev/null and b/The Java Virtual Machine Specification Java SE 8 Edition.pdf differ diff --git a/The Monad Reader Issue - 11.pdf b/The Monad Reader Issue - 11.pdf new file mode 100644 index 0000000..eab3814 Binary files /dev/null and b/The Monad Reader Issue - 11.pdf differ diff --git a/The Monad Reader Issue 11.pdf b/The Monad Reader Issue 11.pdf new file mode 100644 index 0000000..eab3814 Binary files /dev/null and b/The Monad Reader Issue 11.pdf differ diff --git a/The Monad Reader Issue 12.pdf b/The Monad Reader Issue 12.pdf new file mode 100644 index 0000000..326ba12 Binary files /dev/null and b/The Monad Reader Issue 12.pdf differ diff --git a/The Monad Reader Issue 13.pdf b/The Monad Reader Issue 13.pdf new file mode 100644 index 0000000..d418a1a Binary files /dev/null and b/The Monad Reader Issue 13.pdf differ diff --git a/The Monad Reader Issue 15.pdf b/The Monad Reader Issue 15.pdf new file mode 100644 index 0000000..435883b Binary files /dev/null and b/The Monad Reader Issue 15.pdf differ diff --git a/The Monad Reader Issue 16.pdf b/The Monad Reader Issue 16.pdf new file mode 100644 index 0000000..4646c45 Binary files /dev/null and b/The Monad Reader Issue 16.pdf differ diff --git a/The Monad Reader Issue 17.pdf b/The Monad Reader Issue 17.pdf new file mode 100644 index 0000000..31b55f1 Binary files /dev/null and b/The Monad Reader Issue 17.pdf differ diff --git a/The Monad Reader Issue 19.pdf b/The Monad Reader Issue 19.pdf new file mode 100644 index 0000000..1569559 Binary files /dev/null and b/The Monad Reader Issue 19.pdf differ diff --git a/The Monad Reader Issue 21.pdf b/The Monad Reader Issue 21.pdf new file mode 100644 index 0000000..85871cf Binary files /dev/null and b/The Monad Reader Issue 21.pdf differ diff --git a/The Monad Reader Issue 22.pdf b/The Monad Reader Issue 22.pdf new file mode 100644 index 0000000..b72fe8e Binary files /dev/null and b/The Monad Reader Issue 22.pdf differ diff --git a/The Monad Reader Issue 6.pdf b/The Monad Reader Issue 6.pdf new file mode 100644 index 0000000..cc8c45f Binary files /dev/null and b/The Monad Reader Issue 6.pdf differ diff --git a/The Monad Reader Issue 7.pdf b/The Monad Reader Issue 7.pdf new file mode 100644 index 0000000..3cc0d8c Binary files /dev/null and b/The Monad Reader Issue 7.pdf differ diff --git a/The Reader Monad for Dependency Injection.pdf b/The Reader Monad for Dependency Injection.pdf new file mode 100644 index 0000000..0ff676a Binary files /dev/null and b/The Reader Monad for Dependency Injection.pdf differ diff --git a/The Yoneda Lemma - what's it all about.pdf b/The Yoneda Lemma - what's it all about.pdf new file mode 100644 index 0000000..137268a Binary files /dev/null and b/The Yoneda Lemma - what's it all about.pdf differ diff --git a/Theorems for Free!.pdf b/Theorems for Free!.pdf new file mode 100644 index 0000000..918a8e4 Binary files /dev/null and b/Theorems for Free!.pdf differ diff --git a/There and Back Again Arrows for Invertible Programming.pdf b/There and Back Again Arrows for Invertible Programming.pdf new file mode 100644 index 0000000..eacfd27 Binary files /dev/null and b/There and Back Again Arrows for Invertible Programming.pdf differ diff --git a/Towards a Categorical Foundation for Generic Programming.pdf b/Towards a Categorical Foundation for Generic Programming.pdf new file mode 100644 index 0000000..208a0e7 Binary files /dev/null and b/Towards a Categorical Foundation for Generic Programming.pdf differ diff --git a/Towards a Common Categorical Semantics for Linear-Time Temporal Logic and Functional Reactive Programming-slides.pdf b/Towards a Common Categorical Semantics for Linear-Time Temporal Logic and Functional Reactive Programming-slides.pdf new file mode 100644 index 0000000..55b56b2 Binary files /dev/null and b/Towards a Common Categorical Semantics for Linear-Time Temporal Logic and Functional Reactive Programming-slides.pdf differ diff --git a/Towards a Common Categorical Semantics for Linear-Time Temporal Logic and Functional Reactive Programming.pdf b/Towards a Common Categorical Semantics for Linear-Time Temporal Logic and Functional Reactive Programming.pdf new file mode 100644 index 0000000..4fb5328 Binary files /dev/null and b/Towards a Common Categorical Semantics for Linear-Time Temporal Logic and Functional Reactive Programming.pdf differ diff --git "a/Translating Types and E\vects with State Monads and Linear Logic.pdf" "b/Translating Types and E\vects with State Monads and Linear Logic.pdf" new file mode 100644 index 0000000..7ff9055 Binary files /dev/null and "b/Translating Types and E\vects with State Monads and Linear Logic.pdf" differ diff --git a/Types For Programming And Reasoning.pdf b/Types For Programming And Reasoning.pdf new file mode 100644 index 0000000..04f2ecb Binary files /dev/null and b/Types For Programming And Reasoning.pdf differ diff --git a/Types, Abstraction And Parametric Polymorphism.pdf b/Types, Abstraction And Parametric Polymorphism.pdf new file mode 100644 index 0000000..5b24c6a Binary files /dev/null and b/Types, Abstraction And Parametric Polymorphism.pdf differ diff --git a/Unifying Structured Recursion Schemes.pdf b/Unifying Structured Recursion Schemes.pdf new file mode 100644 index 0000000..36f488c Binary files /dev/null and b/Unifying Structured Recursion Schemes.pdf differ diff --git a/Using Circular Programs for Higher-Order Syntax - functional pearl.pdf b/Using Circular Programs for Higher-Order Syntax - functional pearl.pdf new file mode 100644 index 0000000..18e7655 Binary files /dev/null and b/Using Circular Programs for Higher-Order Syntax - functional pearl.pdf differ diff --git a/Using category theory to design implicit conversions and generic operators.pdf b/Using category theory to design implicit conversions and generic operators.pdf new file mode 100644 index 0000000..6f625a9 Binary files /dev/null and b/Using category theory to design implicit conversions and generic operators.pdf differ diff --git a/Vene V. Coding Recursion a la Mendler.pdf b/Vene V. Coding Recursion a la Mendler.pdf new file mode 100644 index 0000000..aa64b57 Binary files /dev/null and b/Vene V. Coding Recursion a la Mendler.pdf differ diff --git a/WGP11.pdf b/WGP11.pdf new file mode 100644 index 0000000..208a0e7 Binary files /dev/null and b/WGP11.pdf differ diff --git a/Well-pointed coalgebras.pdf b/Well-pointed coalgebras.pdf new file mode 100644 index 0000000..2699e22 Binary files /dev/null and b/Well-pointed coalgebras.pdf differ diff --git a/What Does Monad Mean.pdf b/What Does Monad Mean.pdf new file mode 100644 index 0000000..a4aa2a9 Binary files /dev/null and b/What Does Monad Mean.pdf differ diff --git a/What is Categorical Type Theory?.pdf b/What is Categorical Type Theory?.pdf new file mode 100644 index 0000000..5fa5bc1 Binary files /dev/null and b/What is Categorical Type Theory?.pdf differ diff --git a/What is a model of type theory?.pdf b/What is a model of type theory?.pdf new file mode 100644 index 0000000..a819557 Binary files /dev/null and b/What is a model of type theory?.pdf differ diff --git a/WhatIsAStack.pdf b/WhatIsAStack.pdf new file mode 100644 index 0000000..ae99571 Binary files /dev/null and b/WhatIsAStack.pdf differ diff --git a/When is a function a fold or an unfold.pdf b/When is a function a fold or an unfold.pdf new file mode 100644 index 0000000..567e017 Binary files /dev/null and b/When is a function a fold or an unfold.pdf differ diff --git a/Work It, Wrap It, Fix It, Fold It (Extended Version) .pdf b/Work It, Wrap It, Fix It, Fold It (Extended Version) .pdf new file mode 100644 index 0000000..df75bf3 Binary files /dev/null and b/Work It, Wrap It, Fix It, Fold It (Extended Version) .pdf differ diff --git a/Worker:Wrapper:Makes it:Faster.pdf b/Worker:Wrapper:Makes it:Faster.pdf new file mode 100644 index 0000000..a95d939 Binary files /dev/null and b/Worker:Wrapper:Makes it:Faster.pdf differ diff --git a/Yoneda Structures on 2-Categories.pdf b/Yoneda Structures on 2-Categories.pdf new file mode 100644 index 0000000..634002d Binary files /dev/null and b/Yoneda Structures on 2-Categories.pdf differ diff --git a/arrows-and-idioms.pdf b/arrows-and-idioms.pdf new file mode 100644 index 0000000..5a16487 Binary files /dev/null and b/arrows-and-idioms.pdf differ diff --git a/art-of-incremental-stream-processing.pdf b/art-of-incremental-stream-processing.pdf new file mode 100644 index 0000000..a55372c Binary files /dev/null and b/art-of-incremental-stream-processing.pdf differ diff --git a/calc-comp-master/Arith.v b/calc-comp-master/Arith.v new file mode 100755 index 0000000..908c065 --- /dev/null +++ b/calc-comp-master/Arith.v @@ -0,0 +1,112 @@ +(** Calculation of the simple arithmetic language. *) + +Require Import List. +Require Import Tactics. + +(** * Syntax *) + +Inductive Expr : Set := +| Val : nat -> Expr +| Add : Expr -> Expr -> Expr. + +(** * Semantics *) + +Fixpoint eval (e: Expr) : nat := + match e with + | Val n => n + | Add x y => eval x + eval y + end. + +(** * Compiler *) + +Inductive Code : Set := +| PUSH : nat -> Code -> Code +| ADD : Code -> Code +| HALT : Code. + +Fixpoint comp' (e : Expr) (c : Code) : Code := + match e with + | Val n => PUSH n c + | Add x y => comp' x (comp' y (ADD c)) + end. + +Definition comp (e : Expr) : Code := comp' e HALT. + +(** * Virtual Machine *) + +Definition Stack : Set := list nat. + +Definition Conf : Set := prod Code Stack. + +Reserved Notation "x ==> y" (at level 80, no associativity). +Inductive VM : Conf -> Conf -> Prop := +| vm_push n c s : (PUSH n c , s) ==> (c , n :: s) +| vm_add c s m n : (ADD c, m :: n :: s) ==> (c, (n + m) :: s) +where "x ==> y" := (VM x y). + +(** * Calculation *) + +(** Boilerplate to import calculation tactics *) + +Module VM <: Preorder. +Definition Conf := Conf. +Definition VM := VM. +End VM. +Module VMCalc := Calculation VM. +Import VMCalc. + +(** Specification of the compiler *) + +Theorem spec e c s : (comp' e c, s) =>> (c , eval e :: s). + +(** Setup the induction proof *) + +Proof. + intros. + generalize dependent c. + generalize dependent s. + induction e;intros. + +(** Calculation of the compiler *) + +(** - [e = Val n]: *) + + begin + (c, n :: s). + <== { apply vm_push } + (PUSH n c, s). + []. + +(** - [e = Add e1 e2]: *) + + begin + (c, eval e1 + eval e2 :: s). + <== { apply vm_add} + (ADD c, eval e2 :: eval e1 :: s). + <<= { apply IHe2} + (comp' e2 (ADD c), eval e1 :: s). + <<= { apply IHe1} + (comp' e1 (comp' e2 (ADD c)), s). + []. +Qed. + + +(** * Soundness *) + +(** Since the VM is defined as a small step operational semantics, we +have to prove that the VM is deterministic and does not get stuck in +order to derive soundness from the above theorem. *) + + +Lemma determ_vm : determ VM. + intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity. +Qed. + + +Theorem sound e s C : (comp e, s) =>>! C -> C = (HALT , eval e :: s). +Proof. + intros. + pose (spec e HALT) as H'. unfold comp in *. pose (determ_trc determ_vm) as D. + unfold determ in D. eapply D. apply H. split. apply H'. intro Contra. destruct Contra. + inversion H0. +Qed. \ No newline at end of file diff --git a/calc-comp-master/Exceptions.v b/calc-comp-master/Exceptions.v new file mode 100755 index 0000000..6f93833 --- /dev/null +++ b/calc-comp-master/Exceptions.v @@ -0,0 +1,220 @@ +(** Calculation for arithmetic + exceptions. *) + +Require Import List. +Require Import Tactics. + +(** * Syntax *) + +Inductive Expr : Set := +| Val : nat -> Expr +| Add : Expr -> Expr -> Expr +| Throw : Expr +| Catch : Expr -> Expr -> Expr. + +(** * Semantics *) + +Fixpoint eval (e: Expr) : option nat := + match e with + | Val n => Some n + | Add x y => match eval x with + | Some n => match eval y with + | Some m => Some (n + m) + | None => None + end + | None => None + end + | Throw => None + | Catch x y => match eval x with + | Some n => Some n + | None => eval y + end + end. + +(** * Compiler *) + +Inductive Code : Set := +| PUSH : nat -> Code -> Code +| ADD : Code -> Code +| FAIL : Code +| UNMARK : Code -> Code +| MARK : Code -> Code -> Code +| HALT : Code. + +Fixpoint comp' (e : Expr) (c : Code) : Code := + match e with + | Val n => PUSH n c + | Add x y => comp' x (comp' y (ADD c)) + | Throw => FAIL + | Catch x h => MARK (comp' h c) (comp' x (UNMARK c)) + end. + +Definition comp (e : Expr) : Code := comp' e HALT. + +(** * Virtual Machine *) + +Inductive Elem : Set := +| VAL : nat -> Elem +| HAN : Code -> Elem +. +Definition Stack : Set := list Elem. + +Inductive Conf : Set := +| conf : Code -> Stack -> Conf +| fail : Stack -> Conf. + +Notation "⟨ x , y ⟩" := (conf x y). +Notation "⟪ x ⟫" := (fail x ). + +Reserved Notation "x ==> y" (at level 80, no associativity). +Inductive VM : Conf -> Conf -> Prop := +| vm_push n c s : ⟨PUSH n c, s⟩ ==> ⟨ c , VAL n :: s ⟩ +| vm_add c s m n : ⟨ADD c, VAL m :: VAL n :: s⟩ ==> ⟨c, VAL (n + m) :: s⟩ +| vm_fail_val n s : ⟪VAL n :: s ⟫ ==> ⟪s⟫ +| vm_fail s : ⟨ FAIL, s⟩ ==> ⟪s⟫ +| vm_fail_han c s : ⟪HAN c :: s ⟫ ==> ⟨c, s⟩ +| vm_unmark c n h s : ⟨UNMARK c, VAL n :: HAN h :: s⟩ ==> ⟨c, VAL n :: s⟩ +| vm_mark c h s : ⟨MARK h c, s⟩ ==> ⟨c, HAN h :: s⟩ +where "x ==> y" := (VM x y). + +Hint Constructors VM. + +(** * Calculation *) + +(** Boilerplate to import calculation tactics *) + +Module VM <: Preorder. +Definition Conf := Conf. +Definition VM := VM. +End VM. +Module VMCalc := Calculation VM. +Import VMCalc. + +(** Specification of the compiler *) + +Theorem spec e c s : ⟨comp' e c, s⟩ + =>> match eval e with + | Some n => ⟨c , VAL n :: s⟩ + | None => ⟪ s ⟫ + end. + +(** Setup the induction proof *) + +Proof. + intros. + generalize dependent c. + generalize dependent s. + induction e;intros. + +(** Calculation of the compiler *) + +(** - [e = Val n]: *) + + begin + ⟨c, VAL n :: s⟩. + <== { apply vm_push } + ⟨PUSH n c, s⟩. + []. + +(** - [e = Add e1 e2]: *) + + begin + (match eval e1 with + | Some m => match eval e2 with + | Some n => ⟨ c, VAL (m + n) :: s ⟩ + | None => ⟪ s ⟫ + end + | None => ⟪ s ⟫ + end). + <<= { apply vm_add } + (match eval e1 with + | Some m => match eval e2 with + | Some n => ⟨ ADD c, VAL n :: VAL m :: s ⟩ + | None => ⟪ s ⟫ + end + | None => ⟪ s ⟫ + end). + <<= { apply vm_fail_val } + (match eval e1 with + | Some m => match eval e2 with + | Some n => ⟨ ADD c, VAL n :: VAL m :: s ⟩ + | None => ⟪ VAL m :: s ⟫ + end + | None => ⟪ s ⟫ + end). + <<= { apply IHe2 } + (match eval e1 with + | Some m => ⟨ comp' e2 (ADD c), VAL m :: s ⟩ + | None => ⟪ s ⟫ + end). + <<= { apply IHe1 } + ⟨ comp' e1 (comp' e2 (ADD c)), s ⟩. + []. + +(** - [e = Throw]: *) + + begin + ⟪s⟫. + <== { apply vm_fail } + ⟨ FAIL, s⟩. + []. + +(** - [e = Catch e1 e2]: *) + + begin + (match eval e1 with + | Some m => ⟨ c, VAL m :: s⟩ + | None => match eval e2 with + | Some n => ⟨c, VAL n :: s⟩ + | None => ⟪s⟫ + end + end). + <<= { apply IHe2 } + (match eval e1 with + | Some m => ⟨ c, VAL m :: s⟩ + | None => ⟨comp' e2 c, s⟩ + end). + <<= { apply vm_fail_han } + (match eval e1 with + | Some m => ⟨ c, VAL m :: s⟩ + | None => ⟪ HAN (comp' e2 c) :: s⟫ + end). + <<= { apply vm_unmark } + (match eval e1 with + | Some m => ⟨ UNMARK c, VAL m :: HAN (comp' e2 c) :: s⟩ + | None => ⟪ HAN (comp' e2 c) :: s⟫ + end). + <<= { apply IHe1 } + ⟨ comp' e1 (UNMARK c), HAN (comp' e2 c) :: s⟩. + <<= { apply vm_mark } + ⟨ MARK (comp' e2 c) (comp' e1 (UNMARK c)), s⟩. + []. + +Qed. + +(** * Soundness *) + +(** Since the VM is defined as a small step operational semantics, we +have to prove that the VM is deterministic and does not get stuck in +order to derive soundness from the above theorem. *) + +Lemma determ_vm : determ VM. + intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity. +Qed. + +Lemma term_vm x : ~ (exists C, match x with + | Some n => ⟨HALT , VAL n :: nil⟩ + | None => ⟪nil⟫ + end ==> C). +Proof. + destruct x; intro Contra; destruct Contra; subst; inversion H. +Qed. + +Theorem sound e C : ⟨comp e, nil⟩ =>>! C -> C = match eval e with + | Some n => ⟨HALT , VAL n :: nil⟩ + | None => ⟪nil⟫ + end. +Proof. + intros. + pose (spec e HALT nil) as H'. unfold comp in *. pose (determ_trc determ_vm) as D. + unfold determ in D. eapply D. apply H. split. apply H'. apply term_vm. +Qed. \ No newline at end of file diff --git a/calc-comp-master/ExceptionsTwoCont.v b/calc-comp-master/ExceptionsTwoCont.v new file mode 100755 index 0000000..bd9ed4f --- /dev/null +++ b/calc-comp-master/ExceptionsTwoCont.v @@ -0,0 +1,200 @@ +(** Calculation for arithmetic + exceptions with two continuations. *) + +Require Import List. +Require Import Tactics. + +(** * Syntax *) + +Inductive Expr : Set := +| Val : nat -> Expr +| Add : Expr -> Expr -> Expr +| Throw : Expr +| Catch : Expr -> Expr -> Expr. + +(** * Semantics *) + +Fixpoint eval (e: Expr) : option nat := + match e with + | Val n => Some n + | Add x y => match eval x with + | Some n => match eval y with + | Some m => Some (n + m) + | None => None + end + | None => None + end + | Throw => None + | Catch x y => match eval x with + | Some n => Some n + | None => eval y + end + end. + +(** * Compiler *) + +Inductive Code : Set := +| PUSH : nat -> Code -> Code +| ADD : Code -> Code +| POP : Code -> Code +| HALT : Code. + +Fixpoint comp' (e : Expr) (s : Code) (f : Code) : Code := + match e with + | Val n => PUSH n s + | Add x y => comp' x (comp' y (ADD s) (POP f)) f + | Throw => f + | Catch x h => comp' x s (comp' h s f) + end. + +Definition comp (e : Expr) : Code := comp' e HALT HALT. + +(** * Virtual Machine *) + +Inductive Elem : Set := +| VAL : nat -> Elem +. +Definition Stack : Set := list Elem. + +Inductive Conf : Set := +| conf : Code -> Stack -> Conf. + +Notation "⟨ x , y ⟩" := (conf x y). + +Reserved Notation "x ==> y" (at level 80, no associativity). +Inductive VM : Conf -> Conf -> Prop := +| vm_push n c k : ⟨PUSH n c, k⟩ ==> ⟨ c , VAL n :: k ⟩ +| vm_add c k m n : ⟨ADD c, VAL m :: VAL n :: k⟩ ==> ⟨c, VAL (n + m) :: k⟩ +| vm_pop c n k : ⟨POP c, VAL n :: k⟩ ==> ⟨c, k⟩ +where "x ==> y" := (VM x y). + +Hint Constructors VM. + +(** * Calculation *) + +(** Boilerplate to import calculation tactics *) + +Module VM <: Preorder. +Definition Conf := Conf. +Definition VM := VM. +End VM. +Module VMCalc := Calculation VM. +Import VMCalc. + +(** Specification of the compiler *) + +Theorem spec e s f k : ⟨comp' e s f, k⟩ + =>> match eval e with + | Some n => ⟨s , VAL n :: k⟩ + | None => ⟨f , k⟩ + end. + +(** Setup the induction proof *) + +Proof. + intros. + generalize dependent s. + generalize dependent f. + generalize dependent k. + induction e;intros. + +(** Calculation of the compiler *) + +(** - [e = Val n]: *) + + begin + ⟨s, VAL n :: k⟩. + <== { apply vm_push } + ⟨PUSH n s, k⟩. + []. + +(** - [e = Add e1 e2]: *) + + begin + (match eval e1 with + | Some m => match eval e2 with + | Some n => ⟨ s, VAL (m + n) :: k ⟩ + | None => ⟨ f, k ⟩ + end + | None => ⟨ f, k ⟩ + end). + <<= { apply vm_add } + (match eval e1 with + | Some m => match eval e2 with + | Some n => ⟨ ADD s, VAL n :: VAL m :: k ⟩ + | None => ⟨ f, k ⟩ + end + | None => ⟨ f, k ⟩ + end). + <<= { apply vm_pop } + (match eval e1 with + | Some m => match eval e2 with + | Some n => ⟨ ADD s, VAL n :: VAL m :: k ⟩ + | None => ⟨ POP f, VAL m :: k ⟩ + end + | None => ⟨ f, k ⟩ + end). + <<= { apply IHe2 } + (match eval e1 with + | Some m => ⟨ (comp' e2 (ADD s) (POP f)), VAL m :: k⟩ + | None => ⟨ f, k ⟩ + end). + <<= { apply IHe1 } + ⟨ comp' e1 (comp' e2 (ADD s) (POP f)) f, k ⟩. + []. + +(** - [e = Throw]: *) + + begin + ⟨ f, k⟩. + []. + +(** - [e = Catch e1 e2]: *) + + begin + (match eval e1 with + | Some m => ⟨ s, VAL m :: k⟩ + | None => match eval e2 with + | Some n => ⟨s, VAL n :: k⟩ + | None => ⟨f, k⟩ + end + end). + <<= { apply IHe2 } + (match eval e1 with + | Some m => ⟨ s, VAL m :: k⟩ + | None => ⟨comp' e2 s f, k⟩ + end). + <<= { apply IHe1 } + ⟨ comp' e1 s (comp' e2 s f) , k⟩. + []. +Qed. + +(** * Soundness *) + +(** Since the VM is defined as a small step operational semantics, we +have to prove that the VM is deterministic and does not get stuck in +order to derive soundness from the above theorem. *) + + +Lemma determ_vm : determ VM. + intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity. +Qed. + +Lemma term_vm x : ~ (exists C, match x with + | Some n => ⟨HALT , VAL n :: nil⟩ + | None => ⟨HALT , nil⟩ + end ==> C). +Proof. + destruct x; intro Contra; destruct Contra; subst; inversion H. +Qed. + + + +Theorem sound e C : ⟨comp e, nil⟩ =>>! C -> C = match eval e with + | Some n => ⟨HALT , VAL n :: nil⟩ + | None => ⟨HALT , nil⟩ + end. +Proof. + intros. + pose (spec e HALT HALT nil) as H'. unfold comp in *. pose (determ_trc determ_vm) as D. + unfold determ in D. eapply D. apply H. split. apply H'. apply term_vm. +Qed. \ No newline at end of file diff --git a/calc-comp-master/Heap.v b/calc-comp-master/Heap.v new file mode 100755 index 0000000..5a1629b --- /dev/null +++ b/calc-comp-master/Heap.v @@ -0,0 +1,16 @@ +Parameter Heap : Set -> Set. +Parameter Loc : Set. + +Parameter empty : forall {A}, Heap A. +Parameter deref : forall {A}, Heap A -> Loc -> option A. +Parameter update : forall {A}, Heap A -> Loc -> A -> Heap A. +Parameter alloc : forall {A}, Heap A -> A -> (Heap A * Loc). + +Parameter hmap: forall {A B : Set}, (A -> B) -> Heap A -> Heap B. + +Axiom hmap_empty : forall {A B : Set} {f : A -> B}, hmap f empty = empty. +Axiom hmap_deref : forall {A B : Set} {f : A -> B} h l, deref (hmap f h) l = option_map f (deref h l). +Axiom hmap_update : forall {A B : Set} {f : A -> B} h l e, update (hmap f h) l (f e) = hmap f (update h l e). +Axiom hmap_alloc : forall {A B : Set} {f : A -> B} {h : Heap A} {h' : Heap A} l e, + alloc (hmap f h) (f e) = (hmap f h', l) + <-> alloc h e = (h', l). \ No newline at end of file diff --git a/calc-comp-master/Lambda.v b/calc-comp-master/Lambda.v new file mode 100755 index 0000000..e55e32c --- /dev/null +++ b/calc-comp-master/Lambda.v @@ -0,0 +1,220 @@ +(** Calculation of a compiler for the call-by-value lambda calculus + +arithmetic. *) + +Require Import List. +Require Import ListIndex. +Require Import Tactics. + +(** * Syntax *) + +Inductive Expr : Set := +| Val : nat -> Expr +| Add : Expr -> Expr -> Expr +| Var : nat -> Expr +| Abs : Expr -> Expr +| App : Expr -> Expr -> Expr. + +(** * Semantics *) + +(** The evaluator for this language is given as follows (as in the +paper): +<< +type Env = [Value] +data Value = Num Int | Fun (Value -> Value) + + +eval :: Expr -> Env -> Value +eval (Val n) e = Num n +eval (Add x y) e = case eval x e of + Num n -> case eval y e of + Num m -> Num (n+m) +eval (Var i) e = e !! i +eval (Abs x) e = Fun (\v -> eval x (v:e)) +eval (App x y) e = case eval x e of + Fun f -> f (eval y e) +>> +After defunctionalisation and translation into relational form we +obtain the semantics below. *) + +Inductive Value : Set := +| Num : nat -> Value +| Clo : Expr -> list Value -> Value. + +Definition Env := list Value. + +Reserved Notation "x ⇓[ e ] y" (at level 80, no associativity). + +Inductive eval : Expr -> Env -> Value -> Prop := +| eval_val e n : Val n ⇓[e] Num n +| eval_add e x y m n : x ⇓[e] Num m -> y ⇓[e] Num n -> Add x y ⇓[e] Num (m + n) +| eval_var e i v : nth e i = Some v -> Var i ⇓[e] v +| eval_abs e x : Abs x ⇓[e] Clo x e +| eval_app e e' x x' x'' y y' : x ⇓[e] Clo x' e' -> y ⇓[e] y' -> x' ⇓[y' :: e'] x'' -> App x y ⇓[e] x'' +where "x ⇓[ e ] y" := (eval x e y). + +(** * Compiler *) + +Inductive Code : Set := +| PUSH : nat -> Code -> Code +| ADD : Code -> Code +| LOOKUP : nat -> Code -> Code +| RET : Code +| APP : Code -> Code +| ABS : Code -> Code -> Code +| HALT : Code. + +Fixpoint comp' (e : Expr) (c : Code) : Code := + match e with + | Val n => PUSH n c + | Add x y => comp' x (comp' y (ADD c)) + | Var i => LOOKUP i c + | App x y => comp' x (comp' y (APP c)) + | Abs x => ABS (comp' x RET) c + end. + +Definition comp (e : Expr) : Code := comp' e HALT. + +(** * Virtual Machine *) + +Inductive Value' : Set := +| Num' : nat -> Value' +| Clo' : Code -> list Value' -> Value'. + +Definition Env' := list Value'. + +Inductive Elem : Set := +| VAL : Value' -> Elem +| CLO : Code -> Env' -> Elem +. +Definition Stack : Set := list Elem. + +Inductive Conf : Set := +| conf : Code -> Stack -> Env' -> Conf. + +Notation "⟨ x , y , e ⟩" := (conf x y e). + +Reserved Notation "x ==> y" (at level 80, no associativity). +Inductive VM : Conf -> Conf -> Prop := +| vm_push n c s e : ⟨PUSH n c, s, e⟩ ==> ⟨c, VAL (Num' n) :: s, e⟩ +| vm_add c m n s e : ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, e⟩ + ==> ⟨c, VAL (Num'(m + n)) :: s, e⟩ +| vm_lookup e i c v s : nth e i = Some v -> ⟨LOOKUP i c, s, e ⟩ ==> ⟨c, VAL v :: s, e ⟩ +| vm_env v c e e' s : ⟨RET, VAL v :: CLO c e :: s, e'⟩ ==> ⟨c, VAL v :: s, e⟩ +| vm_app c c' e e' v s : ⟨APP c, VAL v :: VAL (Clo' c' e') :: s, e⟩ + ==> ⟨c', CLO c e :: s, v :: e'⟩ +| vm_abs c c' s e : ⟨ABS c' c, s, e ⟩ ==> ⟨c, VAL (Clo' c' e) :: s, e ⟩ +where "x ==> y" := (VM x y). + +(** Conversion functions from semantics to VM *) + +Fixpoint conv (v : Value) : Value' := + match v with + | Num n => Num' n + | Clo x e => Clo' (comp' x RET) (map conv e) + end. + +Definition convE : Env -> Env' := map conv. + +(** * Calculation *) + +(** Boilerplate to import calculation tactics *) + +Module VM <: Preorder. +Definition Conf := Conf. +Definition VM := VM. +End VM. +Module VMCalc := Calculation VM. +Import VMCalc. + +(** Specification of the compiler *) + +Theorem spec p e r c s : p ⇓[e] r -> ⟨comp' p c, s, convE e⟩ + =>> ⟨c , VAL (conv r) :: s, convE e⟩. + +(** Setup the induction proof *) + +Proof. + intros. + generalize dependent c. + generalize dependent s. + induction H;intros. + +(** Calculation of the compiler *) + +(** - [Val n ⇓[e] Num n]: *) + + begin + ⟨c, VAL (Num' n) :: s, convE e⟩. + <== { apply vm_push } + ⟨PUSH n c, s, convE e⟩. + []. + +(** - [Add x y ⇓[e] Num (m + n)]: *) + + begin + ⟨c, VAL (Num' (m + n)) :: s, convE e ⟩. + <== { apply vm_add } + ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, convE e⟩. + <<= { apply IHeval2 } + ⟨comp' y (ADD c), VAL (Num' m) :: s, convE e⟩. + <<= { apply IHeval1 } + ⟨comp' x (comp' y (ADD c)), s, convE e⟩. + []. + +(** - [Var i ⇓[e] v] *) + + begin + ⟨c, VAL (conv v) :: s, convE e ⟩. + <== {apply vm_lookup; unfold convE; erewrite nth_map; eauto} + ⟨LOOKUP i c, s, convE e ⟩. + []. + +(** - [Abs x ⇓[e] Clo x e] *) + + begin + ⟨c, VAL (Clo' (comp' x RET) (convE e)) :: s, convE e ⟩. + <== { apply vm_abs } + ⟨ABS (comp' x RET) c, s, convE e ⟩. + []. + +(** - [App x y ⇓[e] x''] *) + + begin + ⟨c, VAL (conv x'') :: s, convE e ⟩. + <== { apply vm_env } + ⟨RET, VAL (conv x'') :: CLO c (convE e) :: s, convE (y' :: e') ⟩. + <<= { apply IHeval3 } + ⟨comp' x' RET, CLO c (convE e) :: s, convE (y' :: e') ⟩. + = {reflexivity} + ⟨comp' x' RET, CLO c (convE e) :: s, conv y' :: convE e' ⟩. + <== { apply vm_app } + ⟨APP c, VAL (conv y') :: VAL (Clo' (comp' x' RET) (convE e')) :: s, convE e ⟩. + <<= { apply IHeval2 } + ⟨comp' y (APP c), VAL (Clo' (comp' x' RET) (convE e')) :: s, convE e ⟩. + = {reflexivity} + ⟨comp' y (APP c), VAL (conv (Clo x' e')) :: s, convE e ⟩. + <<= { apply IHeval1 } + ⟨comp' x (comp' y (APP c)), s, convE e ⟩. + []. +Qed. + +(** * Soundness *) + +Lemma determ_vm : determ VM. + intros C C1 C2 V. induction V; intro V'; inversion V'; subst; try reflexivity. + rewrite H in H5. inversion H5. reflexivity. +Qed. + + +Definition terminates (p : Expr) : Prop := exists r, p ⇓[nil] r. + +Theorem sound p s C : terminates p -> ⟨comp p, s, nil⟩ =>>! C -> + exists r, C = ⟨HALT , VAL (conv r) :: s, nil⟩ /\ p ⇓[nil] r. +Proof. + unfold terminates. intros. destruct H as [r T]. + + pose (spec p nil r HALT s) as H'. exists r. split. pose (determ_trc determ_vm) as D. + unfold determ in D. eapply D. eassumption. split. auto. intro. destruct H. + inversion H. assumption. +Qed. + \ No newline at end of file diff --git a/calc-comp-master/LambdaCBName.v b/calc-comp-master/LambdaCBName.v new file mode 100755 index 0000000..64e8b73 --- /dev/null +++ b/calc-comp-master/LambdaCBName.v @@ -0,0 +1,239 @@ +(** Calculation of a compiler for the call-by-name lambda calculus + +arithmetic. *) + +Require Import List. +Require Import ListIndex. +Require Import Tactics. + +(** * Syntax *) + +Inductive Expr : Set := +| Val : nat -> Expr +| Add : Expr -> Expr -> Expr +| Var : nat -> Expr +| Abs : Expr -> Expr +| App : Expr -> Expr -> Expr. + +(** * Semantics *) + +(** We start with the evaluator for this language, which is taken from +Ager et al. "A functional correspondence between evaluators and +abstract machines" (we use Haskell syntax to describe the evaluator): +<< +type Env = [Thunk] +data Thunk = Thunk (() -> Value) +data Value = Num Int | Clo (Thunk -> Value) + + +eval :: Expr -> Env -> Value +eval (Val n) e = Num n +eval (Add x y) e = case eval x e of + Num n -> case eval y e of + Num m -> Num (n + m) +eval (Var i) e = case e !! i of + Thunk t -> t () +eval (Abs x) e = Clo (\t -> eval x (t : e)) +eval (App x y) e = case eval x e of + Clo f -> f (Thunk (\_ -> eval y e)) +>> +After defunctionalisation and translation into relational form we +obtain the semantics below. *) + +Inductive Thunk : Set := + | thunk : Expr -> list Thunk -> Thunk. + +Definition Env : Set := list Thunk. + +Inductive Value : Set := +| Num : nat -> Value +| Clo : Expr -> Env -> Value. + +Reserved Notation "x ⇓[ e ] y" (at level 80, no associativity). + +Inductive eval : Expr -> Env -> Value -> Prop := +| eval_val e n : Val n ⇓[e] Num n +| eval_add e x y m n : x ⇓[e] Num m -> y ⇓[e] Num n -> Add x y ⇓[e] Num (m + n) +| eval_var e e' x i v : nth e i = Some (thunk x e') -> x ⇓[e'] v -> Var i ⇓[e] v +| eval_abs e x : Abs x ⇓[e] Clo x e +| eval_app e e' x x' x'' y : x ⇓[e] Clo x' e' -> x' ⇓[thunk y e :: e'] x'' -> App x y ⇓[e] x'' +where "x ⇓[ e ] y" := (eval x e y). + +(** * Compiler *) + +Inductive Code : Set := +| PUSH : nat -> Code -> Code +| ADD : Code -> Code +| RET : Code +| LOOKUP : nat -> Code -> Code +| APP : Code -> Code -> Code +| ABS : Code -> Code -> Code +| HALT : Code. + +Fixpoint comp' (e : Expr) (c : Code) : Code := + match e with + | Val n => PUSH n c + | Add x y => comp' x (comp' y (ADD c)) + | Var i => LOOKUP i c + | App x y => comp' x (APP (comp' y RET) c) + | Abs x => ABS (comp' x RET) c + + end. + +Definition comp (e : Expr) : Code := comp' e HALT. + +(** * Virtual Machine *) + +Inductive Thunk' : Set := + | thunk' : Code -> list Thunk' -> Thunk'. + +Definition Env' : Set := list Thunk'. + +Inductive Value' : Set := +| Num' : nat -> Value' +| Clo' : Code -> Env' -> Value'. + + +Inductive Elem : Set := +| VAL : Value' -> Elem +| CLO : Code -> Env' -> Elem +. +Definition Stack : Set := list Elem. + +Inductive Conf : Set := +| conf : Code -> Stack -> Env' -> Conf. + +Notation "⟨ x , y , e ⟩" := (conf x y e). + +Reserved Notation "x ==> y" (at level 80, no associativity). +Inductive VM : Conf -> Conf -> Prop := +| vm_push n c s e : ⟨PUSH n c, s, e⟩ ==> ⟨c, VAL (Num' n) :: s, e⟩ +| vm_add c m n s e : ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, e⟩ + ==> ⟨c, VAL (Num'(m + n)) :: s, e⟩ +| vm_ret v c e e' s : ⟨RET, VAL v :: CLO c e :: s, e'⟩ ==> ⟨c, VAL v :: s, e⟩ +| vm_lookup e e' i c c' s : nth e i = Some (thunk' c' e') -> ⟨LOOKUP i c, s, e ⟩ ==> ⟨c', CLO c e :: s, e' ⟩ +| vm_app c c' c'' e e' s : ⟨APP c' c, VAL (Clo' c'' e') :: s, e⟩ + ==> ⟨c'', CLO c e :: s, thunk' c' e :: e'⟩ +| vm_abs c c' s e : ⟨ABS c' c, s, e ⟩ ==> ⟨c, VAL (Clo' c' e) :: s, e ⟩ +where "x ==> y" := (VM x y). + +(** Conversion functions from semantics to VM *) + +Fixpoint convT (t : Thunk) : Thunk' := + match t with + | thunk x e => thunk' (comp' x RET) (map convT e) + end. + +Definition convE : Env -> Env' := map convT. + +Fixpoint convV (v : Value) : Value' := + match v with + | Num n => Num' n + | Clo x e => Clo' (comp' x RET) (convE e) + end. + +(** * Calculation *) + +(** Boilerplate to import calculation tactics *) + +Module VM <: Preorder. +Definition Conf := Conf. +Definition VM := VM. +End VM. +Module VMCalc := Calculation VM. +Import VMCalc. + +(** Specification of the compiler *) + +Theorem spec p e r c s : p ⇓[e] r -> ⟨comp' p c, s, convE e⟩ + =>> ⟨c , VAL (convV r) :: s, convE e⟩. + +(** Setup the induction proof *) + +Proof. + intros. + generalize dependent c. + generalize dependent s. + induction H;intros. + +(** Calculation of the compiler *) + +(** - [Val n ⇓[e] Num n]: *) + + begin + ⟨c, VAL (Num' n) :: s, convE e⟩. + <== { apply vm_push } + ⟨PUSH n c, s, convE e⟩. + []. + +(** - [Add x y ⇓[e] Num (m + n)]: *) + + begin + ⟨c, VAL (Num' (m + n)) :: s, convE e ⟩. + <== { apply vm_add } + ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, convE e⟩. + <<= { apply IHeval2 } + ⟨comp' y (ADD c), VAL (Num' m) :: s, convE e⟩. + <<= { apply IHeval1 } + ⟨comp' x (comp' y (ADD c)), s, convE e⟩. + []. + +(** - [Var i ⇓[e] v]: *) + + begin + ⟨c, VAL (convV v) :: s, convE e ⟩. + <== {apply vm_ret} + ⟨RET, VAL (convV v) :: CLO c (convE e) :: s, convE e'⟩. + <<= {apply IHeval} + ⟨comp' x RET, CLO c (convE e) :: s, convE e'⟩. + <== {apply vm_lookup; unfold convE; erewrite nth_map; eauto;reflexivity} + ⟨LOOKUP i c, s, convE e ⟩. + []. + +(** - [Abs x ⇓[e] Clo x e]: *) + + begin + ⟨c, VAL (Clo' (comp' x RET) (convE e)) :: s, convE e ⟩. + <== { apply vm_abs } + ⟨ABS (comp' x RET) c, s, convE e ⟩. + []. + +(** - [App x y ⇓[e] x'']: *) + + begin + ⟨c, VAL (convV x'') :: s, convE e ⟩. + <== { apply vm_ret } + ⟨RET, VAL (convV x'') :: CLO c (convE e) :: s, convE (thunk y e :: e') ⟩. + <<= { apply IHeval2 } + ⟨comp' x' RET, CLO c (convE e) :: s, convE (thunk y e :: e') ⟩. + = {reflexivity} + ⟨comp' x' RET, CLO c (convE e) :: s, thunk' (comp' y RET) (convE e) :: convE e' ⟩. + <== { apply vm_app } + ⟨APP (comp' y RET) c, VAL (Clo' (comp' x' RET) (convE e')) :: s, convE e ⟩. + = { reflexivity } + ⟨APP (comp' y RET) c, VAL (convV (Clo x' e')) :: s, convE e ⟩. + <<= { apply IHeval1 } + ⟨comp' x (APP (comp' y RET) c), s, convE e ⟩. + []. +Qed. + +(** * Soundness *) + +Lemma determ_vm : determ VM. + intros C C1 C2 V. induction V; intro V'; inversion V'; subst; try reflexivity. + rewrite H in H5. inversion H5. reflexivity. +Qed. + + +Definition terminates (p : Expr) : Prop := exists r, p ⇓[nil] r. + +Theorem sound p s C : terminates p -> ⟨comp p, s, nil⟩ =>>! C -> + exists r, C = ⟨HALT , VAL (convV r) :: s, nil⟩ /\ p ⇓[nil] r. +Proof. + unfold terminates. intros. destruct H as [r T]. + + pose (spec p nil r HALT s) as H'. exists r. split. pose (determ_trc determ_vm) as D. + unfold determ in D. eapply D. eassumption. split. auto. intro. destruct H. + inversion H. assumption. +Qed. + + \ No newline at end of file diff --git a/calc-comp-master/LambdaCBNeed.v b/calc-comp-master/LambdaCBNeed.v new file mode 100755 index 0000000..9c3cde8 --- /dev/null +++ b/calc-comp-master/LambdaCBNeed.v @@ -0,0 +1,308 @@ +(** Calculation of a compiler for the call-by-need lambda calculus + +arithmetic. *) + +Require Import List. +Require Import ListIndex. +Require Import Tactics. +Require Import Heap. + +(** * Syntax *) + +Inductive Expr : Set := +| Val : nat -> Expr +| Add : Expr -> Expr -> Expr +| Var : nat -> Expr +| Abs : Expr -> Expr +| App : Expr -> Expr -> Expr. + +(** * Semantics *) + +(** The evaluator for this language is taken from Ager et al. "A +functional correspondence between call-by-need evaluators and lazy +abstract machines". We use Haskell syntax to define the +evaluator. Moreover, we use an abstract interface to a heap +implementation: +<< +type Heap a +type Loc + +empty :: Heap a +deref :: Heap a -> Loc -> a +update :: Heap a -> Loc -> a -> Heap a +alloc :: Heap a -> a -> (Heap a, Loc) +>> +Moreover, we assume that `Heap` forms a functor with an associated function +<< +hmap :: (a -> b) -> Heap a -> Heap b +>> +which in addition to functoriality also satisfies the following laws: +<< +hmap f empty = empty (hmap-empty) +deref (hmap f h) l = f (deref h l) (hmap-deref) +hmap f (update h l e) = update (hmap f h) l (f e) (hmap-update) +alloc (hmap f h) (f e) = (h', l) <=> alloc h e = (hmap f h', l) (hmap-alloc) +>> + +The evaluator itself is defined as follows: +<< +type Env = [Loc] +data HElem = Thunk (Heap HElem -> (Value, Heap HElem)) | Value Value +data Value = Num Int | Clo (Loc -> Heap HElem -> (Value, Heap HElem)) + + +eval :: Expr -> Env -> Heap HElem -> (Value, Heap HElem) +eval (Val n) e h = (Num n, h) +eval (Add x y) e h = case eval x e h of + (Num n, h') -> case eval y e h' of + (Num m, h'') -> (Num (n + m), h'') +eval (Var i) e h = case deref h (e !! i) of + Thunk t -> let (v, h') = t h + in (v, update h' (e !! i) (Value v)) + Value v -> (v, h) +eval (Abs x) e h = (Clo (\ l h' -> eval x (l : e) h') , h) +eval (App x y) e h = case eval x e h of + (Clo , h') -> let (h'',l) = alloc h' (Thunk (\h -> eval y e h)) + in f l h'' +>> +After defunctionalisation and translation into relational form we +obtain the semantics below. *) + +Definition Env : Set := list Loc. + +Inductive Value : Set := +| Num : nat -> Value +| Clo : Expr -> Env -> Value. + +Inductive HElem : Set := + | thunk : Expr -> Env -> HElem + | value : Value -> HElem. + + +Definition Heap := Heap.Heap HElem. + +Reserved Notation "x ⇓[ e , h , h' ] y" (at level 80, no associativity). + +Inductive eval : Expr -> Env -> Heap -> Heap -> Value -> Prop := +| eval_val e n (h h' : Heap) : Val n ⇓[e,h,h] Num n +| eval_add e x y m n h h' h'' : x ⇓[e,h,h'] Num m -> y ⇓[e,h',h''] Num n -> Add x y ⇓[e,h,h''] Num (m + n) +| eval_var_thunk e e' x i l v h h' : nth e i = Some l -> deref h l = Some (thunk x e') -> x ⇓[e',h,h'] v -> + Var i ⇓[e,h,update h' l (value v)] v +| eval_var_val e i l v h : nth e i = Some l -> deref h l = Some (value v) -> + Var i ⇓[e,h,h] v +| eval_abs e x h : Abs x ⇓[e,h,h] Clo x e +| eval_app e e' x x' x'' y l h h' h'' h''' : x ⇓[e,h,h'] Clo x' e' -> alloc h' (thunk y e) = (h'',l) -> + x' ⇓[l :: e',h'',h'''] x'' -> App x y ⇓[e,h,h'''] x'' +where "x ⇓[ e , h , h' ] y" := (eval x e h h' y). + +(** * Compiler *) + +Inductive Code : Set := +| PUSH : nat -> Code -> Code +| ADD : Code -> Code +| WRITE : Code +| LOOKUP : nat -> Code -> Code +| RET : Code +| APP : Code -> Code -> Code +| ABS : Code -> Code -> Code +| HALT : Code. + +Fixpoint comp' (e : Expr) (c : Code) : Code := + match e with + | Val n => PUSH n c + | Add x y => comp' x (comp' y (ADD c)) + | Var i => LOOKUP i c + | App x y => comp' x (APP (comp' y WRITE) c) + | Abs x => ABS (comp' x RET) c + end. + +Definition comp (e : Expr) : Code := comp' e HALT. + +(** * Virtual Machine *) + +Inductive Value' : Set := +| Num' : nat -> Value' +| Clo' : Code -> Env -> Value'. + +Inductive HElem' : Set := + | thunk' : Code -> Env -> HElem' + | value' : Value' -> HElem'. + +Definition Heap' := Heap.Heap HElem'. + +Inductive Elem : Set := +| VAL : Value' -> Elem +| THU : Loc -> Code -> Env -> Elem +| FUN : Code -> Env -> Elem +. +Definition Stack : Set := list Elem. + +Inductive Conf : Set := +| conf : Code -> Stack -> Env -> Heap' -> Conf. + +Notation "⟨ x , y , e , h ⟩" := (conf x y e h). + +Reserved Notation "x ==> y" (at level 80, no associativity). +Inductive VM : Conf -> Conf -> Prop := +| vm_push n c s e h : ⟨PUSH n c, s, e, h⟩ ==> ⟨c, VAL (Num' n) :: s, e, h⟩ +| vm_add c m n s e h : ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, e, h⟩ + ==> ⟨c, VAL (Num'(m + n)) :: s, e, h⟩ +| vm_write e e' l v c s h : ⟨WRITE, VAL v :: THU l c e :: s, e', h⟩ ==> ⟨c, VAL v :: s,e,update h l (value' v)⟩ +| vm_lookup_thunk e e' i c c' h l s : nth e i = Some l -> deref h l = Some (thunk' c' e') -> + ⟨LOOKUP i c, s, e, h⟩ ==> ⟨c', THU l c e :: s, e', h⟩ +| vm_lookup_value e i c h l v s : nth e i = Some l -> deref h l = Some (value' v) -> + ⟨LOOKUP i c, s, e, h⟩ ==> ⟨c, VAL v :: s, e, h⟩ +| vm_ret v c e e' h s : ⟨RET, VAL v :: FUN c e :: s, e', h⟩ ==> ⟨c, VAL v :: s, e, h⟩ +| vm_app c c' c'' e e' s h h' l : alloc h (thunk' c' e) = (h',l) -> + ⟨APP c' c, VAL (Clo' c'' e') :: s, e, h⟩ + ==> ⟨c'', FUN c e :: s, l :: e', h'⟩ +| vm_abs c c' s e h : ⟨ABS c' c, s, e, h⟩ ==> ⟨c, VAL (Clo' c' e) :: s, e, h⟩ +where "x ==> y" := (VM x y). + +(** Conversion functions from semantics to VM *) + +Fixpoint convV (v : Value) : Value' := + match v with + | Num n => Num' n + | Clo x e => Clo' (comp' x RET) e + end. + +Fixpoint convHE (t : HElem) : HElem' := + match t with + | value v => value' (convV v) + | thunk x e => thunk' (comp' x WRITE) e + end. + +Definition convH : Heap -> Heap' := hmap convHE. + +(** * Calculation *) + +(** Boilerplate to import calculation tactics *) + +Module VM <: Preorder. +Definition Conf := Conf. +Definition VM := VM. +End VM. +Module VMCalc := Calculation VM. +Import VMCalc. + +(** Specification of the compiler *) + +Theorem spec p e r c s h h' : p ⇓[e,h,h'] r -> ⟨comp' p c, s, e, convH h⟩ + =>> ⟨c , VAL (convV r) :: s, e, convH h'⟩. + +(** Setup the induction proof *) + +Proof. + intros. + generalize dependent c. + generalize dependent s. + induction H;intros. + +(** Calculation of the compiler *) + +(** - [Val n ⇓[e,h,h] Num n]: *) + + begin + ⟨c, VAL (Num' n) :: s, e, convH h⟩. + <== { apply vm_push } + ⟨PUSH n c, s, e, convH h⟩. + []. + +(** - [Add x y ⇓[e,h,h''] Num (m + n)]: *) + + begin + ⟨c, VAL (Num' (m + n)) :: s, e, convH h'' ⟩. + <== { apply vm_add } + ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, e, convH h''⟩. + <<= { apply IHeval2 } + ⟨comp' y (ADD c), VAL (Num' m) :: s, e, convH h'⟩. + <<= { apply IHeval1 } + ⟨comp' x (comp' y (ADD c)), s, e, convH h⟩. + []. + +(** - [Var i ⇓[e,h,update h' l (value v)] v] *) + + assert (deref (convH h) l = Some (thunk' (comp' x WRITE) e')) + by (unfold convH; rewrite hmap_deref; rewrite H0; reflexivity). + begin + ⟨c, VAL (convV v) :: s, e, convH (update h' l (value v)) ⟩. + = {unfold convH; rewrite <- hmap_update} + ⟨c, VAL (convV v) :: s, e, update (convH h') l (value' (convV v)) ⟩. + <== {apply vm_write} + ⟨WRITE, VAL (convV v) :: THU l c e :: s, e', convH h'⟩. + <<= {apply IHeval} + ⟨comp' x WRITE, THU l c e :: s, e', convH h⟩. + <== {eapply vm_lookup_thunk} + ⟨LOOKUP i c, s, e, convH h ⟩. + []. + +(** - [Var i ⇓[e,h,h] v] *) + + assert (deref (convH h) l = Some (value' (convV v))) + by (unfold convH; rewrite hmap_deref; rewrite H0; reflexivity). + begin + ⟨c, VAL (convV v) :: s, e, convH h ⟩. + <== {eapply vm_lookup_value } + ⟨LOOKUP i c, s, e, convH h ⟩. + []. + +(** - [Abs x ⇓[e,h,h] Clo x e] *) + + begin + ⟨c, VAL (Clo' (comp' x RET) e) :: s, e, convH h ⟩. + <== { apply vm_abs } + ⟨ABS (comp' x RET) c, s, e, convH h ⟩. + []. + +(** - [App x y ⇓[e,h,h'''] x''] *) + + assert (alloc (convH h') (convHE (thunk y e)) = (convH h'', l)). + unfold convH. eapply hmap_alloc in H0. apply H0. + + begin + ⟨c, VAL (convV x'') :: s, e, convH h''' ⟩. + <== { apply vm_ret } + ⟨RET, VAL (convV x'') :: FUN c e :: s, l :: e', convH h''' ⟩. + <<= { apply IHeval2 } + ⟨comp' x' RET, FUN c e :: s, l :: e', convH h'' ⟩. + <== {apply vm_app} + ⟨APP (comp' y WRITE) c, VAL (Clo' (comp' x' RET) e') :: s, e, convH h'⟩. + = {reflexivity} + ⟨APP (comp' y WRITE) c, VAL (convV (Clo x' e')) :: s, e, convH h'⟩. + <<= { apply IHeval1 } + ⟨comp' x (APP (comp' y WRITE) c), s, e, convH h⟩. + []. +Qed. + +(** * Soundness *) + + +(** Custom tactic to apply inversion *) +Ltac inv := match goal with + | [H1 : nth ?e ?i = Some ?l1, + H2 : nth ?e ?i = Some ?l2 |- _] => rewrite H1 in H2; inversion H2; subst; clear H1 H2 + | [H1 : deref ?h ?l = Some ?v1, + H2 : deref ?h ?l = Some ?v2 |- _] => rewrite H1 in H2; inversion H2; subst; clear H1 H2 + | [H1 : alloc ?h ?l = _, + H2 : alloc ?h ?l = _ |- _] => rewrite H1 in H2; inversion H2; subst; clear H1 H2 + | _ => idtac + end. + +Lemma determ_vm : determ VM. + intros C C1 C2 V. induction V; intro V'; inversion V'; subst; repeat inv; try reflexivity. +Qed. + + +Definition terminates (p : Expr) : Prop := exists r h, p ⇓[nil,empty,h] r. + +Theorem sound p s C : terminates p -> ⟨comp p, s, nil, empty⟩ =>>! C -> + exists r h, C = ⟨HALT , VAL (convV r) :: s, nil, convH h⟩ + /\ p ⇓[nil, empty, h] r. +Proof. + unfold terminates. intros. destruct H as [r T]. destruct T as [h T]. + + pose (spec p nil r HALT s) as H'. exists r. exists h. split. pose (determ_trc determ_vm) as D. + unfold determ in D. eapply D. eassumption. split. pose (H' empty h) as H. unfold convH in H. + rewrite hmap_empty in H. apply H. assumption. intro Con. destruct Con. + inversion H. assumption. +Qed. diff --git a/calc-comp-master/ListIndex.v b/calc-comp-master/ListIndex.v new file mode 100755 index 0000000..1bf64d8 --- /dev/null +++ b/calc-comp-master/ListIndex.v @@ -0,0 +1,20 @@ +Require Import List. + +Fixpoint nth {A} (l:list A) (i:nat) : option A := + match l with + | nil => None + | x :: xs => match i with + | 0 => Some x + | S j => nth xs j + end + end. + +Lemma nth_map A B (r : A) l i (f : A -> B) : nth l i = Some r -> nth (map f l) i = Some (f r). +Proof. + intros. + generalize dependent i. + generalize dependent r. + induction l; intros; simpl. inversion H. + + destruct i. inversion H. reflexivity. auto. +Qed. diff --git a/calc-comp-master/Loop.v b/calc-comp-master/Loop.v new file mode 100755 index 0000000..6a2be5d --- /dev/null +++ b/calc-comp-master/Loop.v @@ -0,0 +1,235 @@ +(** Calculation of a compiler for an imperative language with +unbounded loops. *) + +Require Import List. +Require Import ListIndex. +Require Import Tactics. + +(** * Syntax *) + +Inductive Expr : Set := +| Val : nat -> Expr +| Add : Expr -> Expr -> Expr +| Get : Expr. + +Inductive Stmt : Set := +| Put : Expr -> Stmt +| Seqn : Stmt -> Stmt -> Stmt +| While : Expr -> Stmt -> Stmt. + +(** * Semantics *) + +Definition State := nat. +Reserved Notation "x ⇓[ s ] y" (at level 80, no associativity). + +Inductive eval : Expr -> State -> nat -> Prop := +| eval_val s n : Val n ⇓[s] n +| eval_add s x y m n : x ⇓[s] m -> y ⇓[s] n -> Add x y ⇓[s] (m + n) +| eval_get s : Get ⇓[s] s +where "x ⇓[ s ] y" := (eval x s y). + +Reserved Notation "x ↓[ s ] s'" (at level 80, no associativity). + +Inductive run : Stmt -> State -> State -> Prop := +| run_put e s v : e ⇓[s] v -> Put e ↓[s] v +| run_seqn e1 e2 s1 s2 s3 : e1 ↓[s1] s2 -> e2 ↓[s2] s3 -> Seqn e1 e2 ↓[s1] s3 +| run_while_exit e1 e2 s : e1 ⇓[s] 0 -> While e1 e2 ↓[s] s +| run_while_cont v e1 e2 s1 s2 s3 : e1 ⇓[s1] v -> v > 0 -> e2 ↓[s1] s2 -> While e1 e2 ↓[s2] s3 + -> While e1 e2 ↓[s1] s3 +where "x ↓[ s ] y" := (run x s y). + +(** * Compiler *) + +Inductive Code : Set := +| PUSH : nat -> Code -> Code +| ADD : Code -> Code +| GET : Code -> Code +| PUT : Code -> Code +| LOOP : Code +| JMP : Code -> Code -> Code +| ENTER : Code -> Code +| HALT : Code. + +Fixpoint compE (e : Expr) (c : Code) : Code := + match e with + | Val n => PUSH n c + | Add x y => compE x (compE y (ADD c)) + | Get => GET c + end. + +Fixpoint compS (e : Stmt) (c : Code) : Code := + match e with + | Put e => compE e (PUT c) + | Seqn e1 e2 => compS e1 (compS e2 c) + | While e1 e2 => ENTER (compE e1 (JMP c (compS e2 LOOP))) + end. + +Definition comp (e : Stmt) : Code := compS e HALT. + +(** * Virtual Machine *) + +Inductive Elem : Set := +| VAL : nat -> Elem +| CON : Code -> Elem +. + +Definition Stack : Set := list Elem. + +Inductive Conf : Set := +| conf : Code -> Stack -> State -> Conf. + +Notation "⟨ c , k , s ⟩" := (conf c k s). + +Reserved Notation "x ==> y" (at level 80, no associativity). +Inductive VM : Conf -> Conf -> Prop := +| vm_push n c s k : ⟨PUSH n c, k, s⟩ ==> ⟨c, VAL n :: k, s⟩ +| vm_add c m n s k : ⟨ADD c, VAL n :: VAL m :: k, s⟩ + ==> ⟨c, VAL (m + n) :: k, s⟩ +| vm_get c s k : ⟨GET c, k, s⟩ ==> ⟨c, VAL s :: k, s⟩ +| vm_put c v k s : ⟨PUT c, VAL v :: k, s⟩ ==> ⟨c, k, v⟩ +| vm_loop c k s : ⟨LOOP, CON c :: k, s⟩ ==> ⟨c, k, s⟩ +| vm_jmp_yes v c c' k s : v > 0 -> ⟨JMP c' c, VAL v :: k, s⟩ ==> ⟨c, k, s⟩ +| vm_jmp_no c c' c'' k s : ⟨JMP c' c, VAL 0 :: CON c'' :: k, s⟩ ==> ⟨c', k, s⟩ +| vm_enter c k s : ⟨ENTER c, k, s⟩ ==> ⟨c, CON (ENTER c) :: k, s⟩ +where "x ==> y" := (VM x y). + +(** * Calculation *) + +(** Boilerplate to import calculation tactics *) + +Module VM <: Preorder. +Definition Conf := Conf. +Definition VM := VM. +End VM. +Module VMCalc := Calculation VM. +Import VMCalc. + +(** Specification of the compiler for expressions *) +Theorem specExpr e s v k c : e ⇓[s] v -> ⟨compE e c, k, s⟩ + =>> ⟨c , VAL v :: k, s⟩. + +(** Setup the induction proof *) + +Proof. + intros. + generalize dependent c. + generalize dependent k. + induction H;intros. + +(** Calculation of the compiler for expressions *) + +(** - [Val n ⇓[s] n]: *) + + begin + ⟨c, VAL n :: k, s⟩. + <== { apply vm_push } + ⟨PUSH n c, k, s⟩. + []. + +(** - [Add x y ⇓[s] (m + n)]: *) + + begin + ⟨c, VAL (m + n) :: k, s ⟩. + <== { apply vm_add } + ⟨ADD c, VAL n :: VAL m :: k, s⟩. + <<= { apply IHeval2 } + ⟨compE y (ADD c), VAL m :: k, s⟩. + <<= { apply IHeval1 } + ⟨compE x (compE y (ADD c)), k, s⟩. + []. + +(** - [Get ⇓[s] s]: *) + + begin + ⟨c, VAL s :: k, s⟩. + <== {apply vm_get} + ⟨GET c, k, s ⟩. + []. +Qed. + +(** Specification of the compiler for statements *) +Theorem specStmt e s s' k c : e ↓[s] s' -> ⟨compS e c, k, s⟩ + =>> ⟨c , k, s'⟩. + +(** Setup the induction proof *) + +Proof. + intros. + generalize dependent c. + generalize dependent k. + induction H;intros. + +(** Calculation of the compiler for expressions *) + +(** - [Put e ↓[s] v]: *) + + begin + ⟨c, k, v⟩. + <== {apply vm_put} + ⟨PUT c, VAL v :: k, s⟩. + <<= {apply specExpr} + ⟨compE e (PUT c), k, s⟩. + []. + +(** - [Seqn e1 e2 ↓[s1] s3]: *) + + begin + ⟨c, k, s3⟩. + <<= {apply IHrun2} + ⟨compS e2 c, k, s2⟩. + <<= {apply IHrun1} + ⟨compS e1 (compS e2 c), k, s1⟩. + []. + +(** - [While e1 e2 ↓[s] s] ([run_while_exit]): *) + + begin + ⟨c, k, s⟩. + <== {apply vm_jmp_no} + ⟨JMP c (compS e2 LOOP), VAL 0 :: CON (compS (While e1 e2) c) :: k, s⟩. + <<= {apply specExpr} + ⟨compE e1 (JMP c (compS e2 LOOP)), CON (compS (While e1 e2) c) :: k, s ⟩. + <== {apply vm_enter} + ⟨ENTER (compE e1 (JMP c (compS e2 LOOP))), k, s ⟩. + []. + +(** - [While e1 e2 ↓[s1] s3] ([run_while_cont]): *) + + begin + ⟨c, k, s3⟩. + <<= {apply IHrun2} + ⟨compS (While e1 e2) c, k, s2 ⟩. + <== {apply vm_loop} + ⟨LOOP, CON (compS (While e1 e2) c) :: k, s2 ⟩. + <<= {apply IHrun1} + ⟨compS e2 LOOP, CON (compS (While e1 e2) c) :: k, s1 ⟩. + <== {apply vm_jmp_yes} + ⟨JMP c (compS e2 LOOP), VAL v :: CON (compS (While e1 e2) c) :: k, s1 ⟩. + <<= {apply specExpr} + ⟨compE e1 (JMP c (compS e2 LOOP)), CON (compS (While e1 e2) c) :: k, s1 ⟩. + <== {apply vm_enter} + ⟨ENTER (compE e1 (JMP c (compS e2 LOOP))), k, s1 ⟩. + []. + +Qed. + +(** * Soundness *) + +Lemma determ_vm : determ VM. + intros C C1 C2 V. induction V; intro V'; inversion V'; subst; try reflexivity. + inversion H. inversion H5. +Qed. + + +Definition terminates (e : Stmt) : Prop := exists s, e ↓[0] s. + +Theorem sound e C : terminates e -> ⟨comp e, nil, 0⟩ =>>! C -> + exists s, C = ⟨HALT, nil, s⟩ /\ e ↓[0] s. +Proof. + unfold terminates. intros. destruct H as [s T]. + + pose (specStmt e 0 s nil HALT) as H'. exists s. split. pose (determ_trc determ_vm) as D. + unfold determ in D. eapply D. eassumption. split. auto. intro. destruct H. + inversion H. assumption. +Qed. + \ No newline at end of file diff --git a/calc-comp-master/Makefile b/calc-comp-master/Makefile new file mode 100755 index 0000000..fc76b73 --- /dev/null +++ b/calc-comp-master/Makefile @@ -0,0 +1,13 @@ +include makecoq + + +doc: doc/toc.html + +doc/toc.html: $(VOFILES) + mkdir -p doc + coqdoc *.v -d doc -toc --no-index + +cleandoc: + rm -r doc + +cleanall: cleandoc clean diff --git a/calc-comp-master/README.md b/calc-comp-master/README.md new file mode 100755 index 0000000..904ca16 --- /dev/null +++ b/calc-comp-master/README.md @@ -0,0 +1,67 @@ +Calculating Correct Compilers +============================= + +This repository contains the supplementary material for the paper +["Calculating Correct Compilers"](http://www.diku.dk/~paba/pubs/files/bahr14jfp-preprint.pdf) +by Patrick Bahr and Graham Hutton. The material includes Coq +formalisations of all calculations in the paper. In addition, we also +include Coq formalisations for calculations that were mentioned but +not explicitly carried out in the paper. + +The Coq proofs proceed as the calculations in the paper. There are, +however, two minor technical difference due to the nature of the Coq +system. + + 1. In the paper the derived VMs are tail recursive, first-order + functions. The Coq system must be able to prove termination of + all recursive function definitions. Since Coq's termination + checker is not powerful enough to prove termination for some of + the VMs (VMs from sections 3.1, 4.1, 5) or the VMs are not + expected to terminate in general (VMs for lambda calculi / for + language with loops), we had to define the VMs as relations + instead. In particular, all VMs are defined as a small-step + semantics. Each tail recursive function of a VM corresponds to a + configuration constructor in the small-step semantics. As a + consequence, the calculations do not prove equations, but rather + instances of the relation =>>, which is the transitive, reflexive + closure of the relation ==> that defines the VM. + + 2. The Coq files contain the final result of the calculation, and + thus do not reflect the /process/ of discovering the definition + of the compiler and the VM. That is, the files already contain + the full definitions of the compiler and the virtual machine. But + we used the same methodology as described in the paper to + /develop/ the Coq proofs. This is achieved by initially defining + the Code data type as an empty type, defining the VM relation as + an empty relation (i.e. with no rules), and defining the compiler + function using the term "Admit" (which corresponds to Haskell's + "undefined"). This setup then allows us to calculate the + definition of the Code data type, the VM, and the compiler as + described in the paper. + +Below we list the relevant Coq files for the calculations in the +paper: + + - [Arith.v](Arith.v): arithmetic expressions (section 2) + - [Exceptions.v](Exceptions.v): exceptions, first approach (section 3.1) + - [ExceptionsTwoCont.v](ExceptionsTwoCont.v): exceptions, second + approach (section 3.2) + - [StateGlobal.v](StateGlobal.v): global state (section 4.1) + - [StateLocal.v](StateLocal.v): local state (section 4.2) + - [Lambda.v](Lambda.v): call-by-value lambda calculus (section 5) + +In addition we also include calculations for the following languages: + + - [LambdaCBName.v](LambdaCBName.v): call-by-name lambda calculus + - [LambdaCBNeed.v](LambdaCBNeed.v): call-by-need lambda calculus + - [Loop.v](Loop.v): a simple imperative language with while loops + +The remaining files are used to define the Coq tactics to support +reasoning in calculation style ([Tactics.v](Tactics.v)) and to specify +auxiliary concepts ([Heap.v](Heap.v), [ListIndex.v](ListIndex.v)). We +recommend using the +[generated documentation](http://pa-ba.github.io/calc-comp/doc/toc.html) +to browse the Coq files. + +The formalisations were developed using version 8.4pl4 of the Coq +system. diff --git a/calc-comp-master/StateGlobal.v b/calc-comp-master/StateGlobal.v new file mode 100755 index 0000000..41bd08b --- /dev/null +++ b/calc-comp-master/StateGlobal.v @@ -0,0 +1,268 @@ +(** Calculation for arithmetic + exceptions + global state. *) + +Require Import List. +Require Import Tactics. + +(** * Syntax *) + +Inductive Expr : Set := +| Val : nat -> Expr +| Add : Expr -> Expr -> Expr +| Throw : Expr +| Catch : Expr -> Expr -> Expr +| Get : Expr +| Put : Expr -> Expr -> Expr. + +(** * Semantics *) + +Definition State := nat. + +Fixpoint eval (e: Expr) (s : State) : (option nat * State) := + match e with + | Val n => (Some n , s) + | Add x y => match eval x s with + | (Some n, s') => match eval y s' with + | (Some m, s'') => (Some (n + m), s'') + | (None, s'') => (None, s'') + end + | (None, s') => (None, s') + end + | Throw => (None, s) + | Catch x y => match eval x s with + | (Some n, s') => (Some n, s') + | (None, s') => eval y s' + end + | Get => (Some s,s) + | Put x y => match eval x s with + | (Some n, s') => eval y n + | (None, s') => (None, s') + end + end. + +(** * Compiler *) + +Inductive Code : Set := +| HALT : Code +| PUSH : nat -> Code -> Code +| ADD : Code -> Code +| FAIL : Code +| MARK : Code -> Code -> Code +| UNMARK : Code -> Code +| LOAD : Code -> Code +| SAVE : Code -> Code +. + +Fixpoint comp' (e : Expr) (c : Code) : Code := + match e with + | Val n => PUSH n c + | Add x y => comp' x (comp' y (ADD c)) + | Throw => FAIL + | Catch x h => MARK (comp' h c) (comp' x (UNMARK c)) + | Get => LOAD c + | Put x y => comp' x (SAVE (comp' y c)) + end. + +Definition comp (e : Expr) : Code := comp' e HALT. + +(** * Virtual Machine *) + +Inductive Elem : Set := +| VAL : nat -> Elem +| HAN : Code -> Elem +. +Definition Stack : Set := list Elem. + +Inductive Conf : Set := +| conf : Code -> Stack -> State -> Conf +| fail : Stack -> State -> Conf. + +Notation "⟨ c , k , s ⟩" := (conf c k s). +Notation "⟪ k , s ⟫" := (fail k s ). + +Reserved Notation "x ==> y" (at level 80, no associativity). +Inductive VM : Conf -> Conf -> Prop := +| vm_push n c k s : ⟨PUSH n c, k, s⟩ ==> ⟨ c , VAL n :: k, s ⟩ +| vm_add c k s m n : ⟨ADD c, VAL m :: VAL n :: k, s⟩ ==> ⟨c, VAL (n + m) :: k, s⟩ +| vm_fail k s : ⟨ FAIL, k, s⟩ ==> ⟪k,s⟫ +| vm_mark c h k s : ⟨MARK h c, k, s⟩ ==> ⟨c, HAN h :: k, s⟩ +| vm_unmark c n h k s : ⟨UNMARK c, VAL n :: HAN h :: k, s⟩ ==> ⟨c, VAL n :: k, s⟩ +| vm_load c k s : ⟨LOAD c, k, s⟩ ==> ⟨c, VAL s :: k, s⟩ +| vm_save c n k s : ⟨SAVE c, VAL n :: k, s⟩ ==> ⟨c, k, n⟩ +| vm_fail_val n k s : ⟪VAL n :: k, s ⟫ ==> ⟪k, s⟫ +| vm_fail_han c k s : ⟪HAN c :: k, s ⟫ ==> ⟨c, k, s⟩ +where "x ==> y" := (VM x y). + +Hint Constructors VM. + +(** * Calculation *) + +(** Boilerplate to import calculation tactics *) + +Module VM <: Preorder. +Definition Conf := Conf. +Definition VM := VM. +End VM. +Module VMCalc := Calculation VM. +Import VMCalc. + +(** Specification of the compiler *) + +Theorem spec e c k s : ⟨comp' e c, k, s⟩ + =>> match eval e s with + | (Some n, s') => ⟨c , VAL n :: k, s'⟩ + | (None, s') => ⟪ k, s' ⟫ + end. + +(** Setup the induction proof *) + +Proof. + intros. + generalize dependent c. + generalize dependent k. + generalize dependent s. + induction e;intros. + +(** Calculation of the compiler *) + +(** - [e = Val n]: *) + + begin + ⟨c, VAL n :: k, s⟩. + <== { apply vm_push } + ⟨PUSH n c, k, s⟩. + []. + +(** - [e = Add e1 e2]: *) + + begin + (match eval e1 s with + | (Some m, s') => match eval e2 s' with + | (Some n, s'') => ⟨ c, VAL (m + n) :: k, s'' ⟩ + | (None, s'') => ⟪ k, s'' ⟫ + end + | (None, s') => ⟪ k, s' ⟫ + end). + <<= { apply vm_add } + (match eval e1 s with + | (Some m, s') => match eval e2 s' with + | (Some n, s'') => ⟨ ADD c, VAL n :: VAL m :: k, s'' ⟩ + | (None, s'') => ⟪ k, s'' ⟫ + end + | (None, s') => ⟪ k, s' ⟫ + end). + <<= { apply vm_fail_val } + (match eval e1 s with + | (Some m, s') => match eval e2 s' with + | (Some n, s'') => ⟨ ADD c, VAL n :: VAL m :: k, s'' ⟩ + | (None, s'') => ⟪ VAL m :: k, s'' ⟫ + end + | (None, s') => ⟪ k, s' ⟫ + end). + <<= { apply IHe2 } + (match eval e1 s with + | (Some m, s') => ⟨ comp' e2 (ADD c), VAL m :: k, s' ⟩ + | (None, s') => ⟪ k, s' ⟫ + end). + <<= { apply IHe1 } + ⟨ comp' e1 (comp' e2 (ADD c)), k, s ⟩. + []. + +(** - [e = Throw]: *) + + begin + ⟪k, s⟫. + <== { apply vm_fail } + ⟨ FAIL, k, s⟩. + []. + +(** - [e = Catch e1 e2]: *) + + begin + (match eval e1 s with + | (Some m, s') => ⟨ c, VAL m :: k, s'⟩ + | (None, s') => match eval e2 s' with + | (Some n, s'') => ⟨c, VAL n :: k, s''⟩ + | (None, s'') => ⟪k, s''⟫ + end + end). + <<= { apply IHe2 } + (match eval e1 s with + | (Some m, s') => ⟨ c, VAL m :: k, s'⟩ + | (None, s') => ⟨comp' e2 c, k, s'⟩ + end). + <<= { apply vm_fail_han } + (match eval e1 s with + | (Some m, s') => ⟨ c, VAL m :: k, s'⟩ + | (None, s') => ⟪ HAN (comp' e2 c) :: k, s'⟫ + end). + <<= { apply vm_unmark } + (match eval e1 s with + | (Some m, s') => ⟨ UNMARK c, VAL m :: HAN (comp' e2 c) :: k, s'⟩ + | (None, s') => ⟪ HAN (comp' e2 c) :: k, s'⟫ + end). + <<= { apply IHe1 } + ⟨ comp' e1 (UNMARK c), HAN (comp' e2 c) :: k, s⟩. + <<= { apply vm_mark } + ⟨ MARK (comp' e2 c) (comp' e1 (UNMARK c)), k, s⟩. + []. + +(** - [e = Get]: *) + + begin + ⟨ c, VAL s :: k, s⟩. + <== { apply vm_load } + ⟨ LOAD c, k, s⟩. + []. + +(** - [e = Put e1 e2]: *) + + begin + (match eval e1 s with + | (Some n, s') => match eval e2 n with + | (Some m, s'') => ⟨c, VAL m :: k, s''⟩ + | (None, s'') => ⟪k, s''⟫ + end + | (None, s') => ⟪k, s'⟫ + end). + <<= { apply IHe2 } + (match eval e1 s with + | (Some n, s') => ⟨comp' e2 c, k, n⟩ + | (None, s') => ⟪k, s'⟫ + end). + <<= { apply vm_save } + (match eval e1 s with + | (Some n, s') => ⟨SAVE (comp' e2 c), VAL n :: k, s'⟩ + | (None, s') => ⟪k, s'⟫ + end). + <<= { apply IHe1 } + ⟨comp' e1 (SAVE (comp' e2 c)), k, s⟩. + []. +Qed. + +(** * Soundness *) + +(** Since the VM is defined as a small step operational semantics, we +have to prove that the VM is deterministic and does not get stuck in +order to derive soundness from the above theorem. *) + +Lemma determ_vm : determ VM. + intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity. +Qed. + +Lemma term_vm x : ~ (exists C, match x with + | (Some n, s) => ⟨HALT , VAL n :: nil, s⟩ + | (None, s) => ⟪nil, s⟫ + end ==> C). +Proof. + destruct x; destruct o; intro Contra; destruct Contra; subst; inversion H. +Qed. + +Theorem sound e C s : ⟨comp e, nil, s⟩ =>>! C -> C = match eval e s with + | (Some n, s') => ⟨HALT , VAL n :: nil, s'⟩ + | (None, s') => ⟪nil, s'⟫ + end. +Proof. + intros. + pose (spec e HALT nil) as H'. unfold comp in *. pose (determ_trc determ_vm) as D. + unfold determ in D. eapply D. apply H. split. apply H'. apply term_vm. +Qed. \ No newline at end of file diff --git a/calc-comp-master/StateLocal.v b/calc-comp-master/StateLocal.v new file mode 100755 index 0000000..47d228b --- /dev/null +++ b/calc-comp-master/StateLocal.v @@ -0,0 +1,268 @@ +(** Calculation for arithmetic + exceptions + local state. *) + +Require Import List. +Require Import Tactics. + +(** * Syntax *) + +Inductive Expr : Set := +| Val : nat -> Expr +| Add : Expr -> Expr -> Expr +| Throw : Expr +| Catch : Expr -> Expr -> Expr +| Get : Expr +| Put : Expr -> Expr -> Expr. + +(** * Semantics *) + +Definition State := nat. + +Fixpoint eval (e: Expr) (s : State) : option (nat * State) := + match e with + | Val n => Some (n , s) + | Add x y => match eval x s with + | Some (n, s') => match eval y s' with + | Some (m, s'') => Some ((n + m), s'') + | None => None + end + | None => None + end + | Throw => None + | Catch x y => match eval x s with + | Some (n, s') => Some (n, s') + | None => eval y s + end + | Get => Some (s, s) + | Put x y => match eval x s with + | Some (n, s') => eval y n + | None => None + end + end. + +(** * Compiler *) + +Inductive Code : Set := +| HALT : Code +| PUSH : nat -> Code -> Code +| ADD : Code -> Code +| FAIL : Code +| MARK : Code -> Code -> Code +| UNMARK : Code -> Code +| LOAD : Code -> Code +| SAVE : Code -> Code +. + +Fixpoint comp' (e : Expr) (c : Code) : Code := + match e with + | Val n => PUSH n c + | Add x y => comp' x (comp' y (ADD c)) + | Throw => FAIL + | Catch x h => MARK (comp' h c) (comp' x (UNMARK c)) + | Get => LOAD c + | Put x y => comp' x (SAVE (comp' y c)) + end. + +Definition comp (e : Expr) : Code := comp' e HALT. + +(** * Virtual Machine *) + +Inductive Elem : Set := +| VAL : nat -> Elem +| HAN : Code -> State -> Elem +. +Definition Stack : Set := list Elem. + +Inductive Conf : Set := +| conf : Code -> Stack -> State -> Conf +| fail : Stack -> Conf. + +Notation "⟨ c , k , s ⟩" := (conf c k s). +Notation "⟪ k ⟫" := (fail k ). + +Reserved Notation "x ==> y" (at level 80, no associativity). +Inductive VM : Conf -> Conf -> Prop := +| vm_push n c k s : ⟨PUSH n c, k, s⟩ ==> ⟨ c , VAL n :: k, s ⟩ +| vm_add c k s m n : ⟨ADD c, VAL m :: VAL n :: k, s⟩ ==> ⟨c, VAL (n + m) :: k, s⟩ +| vm_fail k s : ⟨ FAIL, k, s⟩ ==> ⟪k⟫ +| vm_mark c h k s : ⟨MARK h c, k, s⟩ ==> ⟨c, HAN h s :: k, s⟩ +| vm_unmark c n h k s s' : ⟨UNMARK c, VAL n :: HAN h s' :: k, s⟩ ==> ⟨c, VAL n :: k, s⟩ +| vm_load c k s : ⟨LOAD c, k, s⟩ ==> ⟨c, VAL s :: k, s⟩ +| vm_save c n k s : ⟨SAVE c, VAL n :: k, s⟩ ==> ⟨c, k, n⟩ +| vm_fail_val n k : ⟪VAL n :: k ⟫ ==> ⟪k⟫ +| vm_fail_han c k s : ⟪HAN c s :: k ⟫ ==> ⟨c, k, s⟩ +where "x ==> y" := (VM x y). + +Hint Constructors VM. + +(** * Calculation *) + +(** Boilerplate to import calculation tactics *) + +Module VM <: Preorder. +Definition Conf := Conf. +Definition VM := VM. +End VM. +Module VMCalc := Calculation VM. +Import VMCalc. + +(** Specification of the compiler *) + +Theorem spec e c k s : ⟨comp' e c, k, s⟩ + =>> match eval e s with + | Some (n, s') => ⟨c , VAL n :: k, s'⟩ + | None => ⟪k⟫ + end. + +(** Setup the induction proof *) + +Proof. + intros. + generalize dependent c. + generalize dependent k. + generalize dependent s. + induction e;intros. + +(** Calculation of the compiler *) + +(** - [e = Val n]: *) + + begin + ⟨c, VAL n :: k, s⟩. + <== { apply vm_push } + ⟨PUSH n c, k, s⟩. + []. + +(** - [e = Add e1 e2]: *) + + begin + (match eval e1 s with + | Some (m, s') => match eval e2 s' with + | Some (n, s'') => ⟨ c, VAL (m + n) :: k, s'' ⟩ + | None => ⟪ k ⟫ + end + | None => ⟪ k ⟫ + end). + <<= { apply vm_add } + (match eval e1 s with + | Some (m, s') => match eval e2 s' with + | Some (n, s'') => ⟨ ADD c, VAL n :: VAL m :: k, s'' ⟩ + | None => ⟪ k ⟫ + end + | None => ⟪ k ⟫ + end). + <<= { apply vm_fail_val } + (match eval e1 s with + | Some (m, s') => match eval e2 s' with + | Some (n, s'') => ⟨ ADD c, VAL n :: VAL m :: k, s'' ⟩ + | None => ⟪ VAL m :: k ⟫ + end + | None => ⟪ k ⟫ + end). + <<= { apply IHe2 } + (match eval e1 s with + | Some (m, s') => ⟨ comp' e2 (ADD c), VAL m :: k, s' ⟩ + | None => ⟪ k ⟫ + end). + <<= { apply IHe1 } + ⟨ comp' e1 (comp' e2 (ADD c)), k, s ⟩. + []. + +(** - [e = Throw]: *) + + begin + ⟪k⟫. + <== { apply vm_fail } + ⟨ FAIL, k, s⟩. + []. + +(** - [e = Catch e1 e2]: *) + + begin + (match eval e1 s with + | Some (m, s') => ⟨ c, VAL m :: k, s'⟩ + | None => match eval e2 s with + | Some (n, s'') => ⟨c, VAL n :: k, s''⟩ + | None => ⟪k⟫ + end + end). + <<= { apply IHe2 } + (match eval e1 s with + | Some (m, s') => ⟨ c, VAL m :: k, s'⟩ + | None => ⟨comp' e2 c, k, s⟩ + end). + <<= { apply vm_fail_han } + (match eval e1 s with + | Some (m, s') => ⟨ c, VAL m :: k, s'⟩ + | None => ⟪ HAN (comp' e2 c) s :: k⟫ + end). + <<= { apply vm_unmark } + (match eval e1 s with + | Some (m, s') => ⟨ UNMARK c, VAL m :: HAN (comp' e2 c) s :: k, s'⟩ + | None => ⟪ HAN (comp' e2 c) s :: k⟫ + end). + <<= { apply IHe1 } + ⟨ comp' e1 (UNMARK c), HAN (comp' e2 c) s :: k, s⟩. + <<= { apply vm_mark } + ⟨ MARK (comp' e2 c) (comp' e1 (UNMARK c)), k, s⟩. + []. + +(** - [e = Get]: *) + + begin + ⟨ c, VAL s :: k, s⟩. + <== { apply vm_load } + ⟨ LOAD c, k, s⟩. + []. + +(** - [e = Put e1 e2]: *) + + begin + (match eval e1 s with + | Some (n, s') => match eval e2 n with + | Some (m, s'') => ⟨c, VAL m :: k, s''⟩ + | None => ⟪k⟫ + end + | None => ⟪k⟫ + end). + <<= { apply IHe2 } + (match eval e1 s with + | Some (n, s') => ⟨comp' e2 c, k, n⟩ + | None => ⟪k⟫ + end). + <<= { apply vm_save } + (match eval e1 s with + | Some (n, s') => ⟨SAVE (comp' e2 c), VAL n :: k, s'⟩ + | None => ⟪k⟫ + end). + <<= { apply IHe1 } + ⟨comp' e1 (SAVE (comp' e2 c)), k, s⟩. + []. +Qed. + +(** * Soundness *) + +(** Since the VM is defined as a small step operational semantics, we +have to prove that the VM is deterministic and does not get stuck in +order to derive soundness from the above theorem. *) + +Lemma determ_vm : determ VM. + intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity. +Qed. + +Lemma term_vm x : ~ (exists C, match x with + | Some (n, s) => ⟨HALT , VAL n :: nil, s⟩ + | None => ⟪nil⟫ + end ==> C). +Proof. + destruct x; try destruct p; intro Contra; destruct Contra; subst; inversion H. +Qed. + +Theorem sound e C s : ⟨comp e, nil, s⟩ =>>! C -> C = match eval e s with + | Some (n, s') => ⟨HALT , VAL n :: nil, s'⟩ + | None => ⟪nil⟫ + end. +Proof. + intros. + pose (spec e HALT nil) as H'. unfold comp in *. pose (determ_trc determ_vm) as D. + unfold determ in D. eapply D. apply H. split. apply H'. apply term_vm. +Qed. \ No newline at end of file diff --git a/calc-comp-master/Tactics.v b/calc-comp-master/Tactics.v new file mode 100755 index 0000000..2a660b4 --- /dev/null +++ b/calc-comp-master/Tactics.v @@ -0,0 +1,152 @@ +Definition Admit {A} : A. admit. Defined. + +Module Type Preorder. + +Parameter Conf : Type. +Parameter VM : Conf -> Conf -> Prop. + +End Preorder. + +Module Calculation (Ord : Preorder). +Import Ord. + +Notation "x ==> y" := (VM x y) (at level 80, no associativity). + +Reserved Notation "x =>> y" (at level 80, no associativity). +Inductive trc : Conf -> Conf -> Prop := +| trc_refl c : c =>> c +| trc_step_trans c1 c2 c3 : c1 ==> c2 -> c2 =>> c3 -> c1 =>> c3 + where "x =>> y" := (trc x y). + + +Lemma trc_step c1 c2 : c1 ==> c2 -> c1 =>> c2. +Proof. + intros. + eapply trc_step_trans. eassumption. apply trc_refl. +Qed. + +Lemma trc_trans c1 c2 c3 : c1 =>> c2 -> c2 =>> c3 -> c1 =>> c3. +Proof. + intros T S. + induction T. assumption. eapply trc_step_trans. eassumption. apply IHT. assumption. +Qed. + + +Corollary trc_step_trans' c1 c2 c3 : c1 =>> c2 -> c2 ==> c3 -> c1 =>> c3. +Proof. + intros. eapply trc_trans. eassumption. apply trc_step. assumption. +Qed. + +Corollary trc_eq_trans c1 c2 c3 : c1 =>> c2 -> c2 = c3 -> c1 =>> c3. +Proof. + intros. eapply trc_trans. eassumption. subst. apply trc_refl. +Qed. + +Ltac dist t := idtac; simpl; try solve [t;eauto|apply trc_step;t;eauto|apply trc_refl;t;eauto] ; match goal with + | [ |- context [let _ := ?x in _] ] => destruct x;dist t + | [ |- context [match ?x with + | _ => _ + end]] => destruct x; dist t + end. + +Ltac dist_refl := dist reflexivity. + + +Ltac check_exp' x y t := let h := fresh "check" in assert (h: x = y) by t; try rewrite <- h; clear h. +Ltac check_exp x y := let h := fresh "check" in assert (h: x = y) by reflexivity; clear h. + +Ltac check_rel R Rel := first [check_exp R Rel| + fail 2 "wrong goal; expected relation" R "but found" Rel]. + + + +Tactic Notation "[]" := apply trc_refl. + + + + +Ltac step rel lem t1 e2 := + match goal with + | [|- ?Rel ?lhs ?rhs] => check_rel trc Rel; + first [let h := fresh "rewriting" in + assert(h : rel e2 rhs) by (dist t1) ; apply (fun x => lem _ _ _ x h); clear h | fail 2] + | _ => fail 1 "goal is not a VM" + end. + +Tactic Notation (at level 2) "<<=" "{"tactic(t) "}" constr(e) := + step trc trc_trans t e. + +Tactic Notation (at level 2) "=" "{"tactic(t) "}" constr(e) := + step (@eq Conf) trc_eq_trans t e. + +Tactic Notation (at level 2) "<==" "{"tactic(t) "}" constr(e) := + step VM trc_step_trans' t e. + +Ltac step_try rel e2 := + match goal with + | [|- ?Rel ?lhs ?rhs] => check_rel trc Rel; + first [let h := fresh "step_try" in assert(h : rel e2 rhs)|fail 2] + | _ => fail 1 "goal is not a VM" + end. + +Tactic Notation (at level 2) "<<=" "{?}" constr(e) := step_try trc e. +Tactic Notation (at level 2) "<==" "{?}" constr(e) := step_try VM e. +Tactic Notation (at level 2) "=" "{?}" constr(e) := step_try (@eq Conf) e. + +Tactic Notation (at level 2) "<==" "{"tactic(t1) "}?" := + match goal with + | [|- ?Rel ?lhs ?rhs] => check_rel trc Rel; + first [eapply trc_trans; [idtac|solve[t1]] | fail 2] + | _ => fail 1 "goal is not a VM" + end. + +Tactic Notation (at level 2) "begin" constr(rhs) := match goal with + | [|- ?Rel ?lhs ?rhs'] => check_rel trc Rel; check_exp' rhs rhs' dist_refl + | _ => fail 1 "rhs does not match" + end. + + +Inductive barred (P : Conf -> Prop) : Conf -> Prop := +| barred_here c : P c -> barred P c +| barred_next c : (forall c', c ==> c' -> barred P c') -> barred P c. + +Lemma barred_if c (P Q : Conf -> Prop) : (forall c, P c -> Q c) -> barred P c -> barred Q c. +Proof. + intros. induction H0. apply barred_here. auto. + apply barred_next. assumption. +Qed. + +Lemma barred_step (P : Conf -> Prop) c :(forall c', c ==> c' -> P c') -> barred P c. +Proof. + intros. apply barred_next. intros. apply barred_here. auto. +Qed. + +Definition determ {A} (R : A -> A -> Prop) : Prop := forall C C1 C2, R C C1 -> R C C2 -> C1 = C2. + + +Definition trc' C C' := C =>> C' /\ ~ exists C'', C' ==> C''. + +Notation "x =>>! y" := (trc' x y) (at level 80, no associativity). + + +Lemma determ_factor C1 C2 C3 : determ VM -> C1 ==> C2 -> C1 =>>! C3 -> C2 =>> C3. +Proof. + unfold determ. intros. destruct H1. + destruct H1. exfalso. apply H2. eexists. eassumption. + + assert (c2 = C2). eapply H. apply H1. apply H0. subst. assumption. +Qed. + + +Lemma determ_trc : determ VM -> determ trc'. +Proof. + intros. unfold determ. intros. destruct H0. + induction H0. + + destruct H1. destruct H0. reflexivity. exfalso. apply H2. eexists. eassumption. + + apply IHtrc. apply H2. split. eapply determ_factor; eassumption. destruct H1. assumption. +Qed. + + +End Calculation. \ No newline at end of file diff --git a/calc-comp-master/makecoq b/calc-comp-master/makecoq new file mode 100755 index 0000000..7b3658b --- /dev/null +++ b/calc-comp-master/makecoq @@ -0,0 +1,237 @@ +############################################################################# +## v # The Coq Proof Assistant ## +## "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) + +%.v.beautified: + $(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $* + +# WARNING +# +# This Makefile has been automagically generated +# Edit at your own risks ! +# +# END OF WARNING + diff --git a/ccc.ppt b/ccc.ppt new file mode 100644 index 0000000..4a28e12 Binary files /dev/null and b/ccc.ppt differ diff --git a/compdata-param-master/.gitignore b/compdata-param-master/.gitignore new file mode 100755 index 0000000..5e66a7e --- /dev/null +++ b/compdata-param-master/.gitignore @@ -0,0 +1,11 @@ +build +dist +dummy.cabal +*~ +*\# +*.orig +*.o +*.hi +*.tix +*.mix +hpcreport diff --git a/compdata-param-master/LICENSE b/compdata-param-master/LICENSE new file mode 100755 index 0000000..9f451e3 --- /dev/null +++ b/compdata-param-master/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2010--2011 Patrick Bahr, Tom Hvitved + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/compdata-param-master/Setup.hs b/compdata-param-master/Setup.hs new file mode 100755 index 0000000..bf68901 --- /dev/null +++ b/compdata-param-master/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain \ No newline at end of file diff --git a/compdata-param-master/compdata-param.cabal b/compdata-param-master/compdata-param.cabal new file mode 100755 index 0000000..0cd028a --- /dev/null +++ b/compdata-param-master/compdata-param.cabal @@ -0,0 +1,106 @@ +Name: compdata-param +Version: 0.8.0.2 +Synopsis: Parametric Compositional Data Types +Description: + + Based on Wouter Swierstra's Functional Pearl /Data types a la carte/ + (Journal of Functional Programming, 18(4):423-436, 2008, + ), this package + provides a framework for defining recursive data types in a + compositional manner with support for binders. + . + This package implemements /parametric compositional data types/ + (Workshop on Mathematically Structured Functional Programming, 3-24, + 2012, ), generalising + compositional data types (as implemented in the /compdata/ package) + with support for parametric higher-order abstract syntax + (PHOAS). + . + Examples of using parametric compositional data types are bundled + with the package in the folder @examples@. + +Category: Generics +License: BSD3 +License-file: LICENSE +Author: Patrick Bahr, Tom Hvitved +Maintainer: paba@di.ku.dk +Build-Type: Simple +Cabal-Version: >=1.9.2 +bug-reports: https://github.com/pa-ba/compdata-param/issues + +extra-source-files: + -- test files + testsuite/tests/Tests.hs + testsuite/tests/Data/Comp/Examples_Test.hs + testsuite/tests/Data/Comp/Examples/*.hs + -- example files + examples/Examples/*.hs + examples/Examples/Multi/*.hs + + +library + Exposed-Modules: Data.Comp.Param + Data.Comp.Param.Term + Data.Comp.Param.FreshM + Data.Comp.Param.Sum + Data.Comp.Param.Difunctor + Data.Comp.Param.Ditraversable + Data.Comp.Param.Algebra + Data.Comp.Param.Annotation + Data.Comp.Param.Ops + Data.Comp.Param.Equality + Data.Comp.Param.Ordering + Data.Comp.Param.Show + Data.Comp.Param.Derive, + Data.Comp.Param.Desugar + Data.Comp.Param.Thunk + + Data.Comp.Param.Multi + Data.Comp.Param.Multi.Term + Data.Comp.Param.Multi.FreshM + Data.Comp.Param.Multi.Sum + Data.Comp.Param.Multi.HDifunctor + Data.Comp.Param.Multi.HDitraversable + Data.Comp.Param.Multi.Algebra + Data.Comp.Param.Multi.Annotation + Data.Comp.Param.Multi.Ops + Data.Comp.Param.Multi.Equality + Data.Comp.Param.Multi.Ordering + Data.Comp.Param.Multi.Show + Data.Comp.Param.Multi.Derive, + Data.Comp.Param.Multi.Desugar + + Other-Modules: Data.Comp.Param.Derive.Difunctor + Data.Comp.Param.Derive.Ditraversable + Data.Comp.Param.Derive.Equality + Data.Comp.Param.Derive.Ordering + Data.Comp.Param.Derive.Show + Data.Comp.Param.Derive.SmartConstructors + Data.Comp.Param.Derive.SmartAConstructors + Data.Comp.Param.Derive.Injections + Data.Comp.Param.Derive.Projections + + Data.Comp.Param.Multi.Derive.HDifunctor + Data.Comp.Param.Multi.Derive.Equality + Data.Comp.Param.Multi.Derive.Ordering + Data.Comp.Param.Multi.Derive.Show + Data.Comp.Param.Multi.Derive.SmartConstructors + Data.Comp.Param.Multi.Derive.SmartAConstructors + Data.Comp.Param.Multi.Derive.Injections + Data.Comp.Param.Multi.Derive.Projections + + Build-Depends: base >= 4.7, base < 5, template-haskell, mtl, transformers, compdata >= 0.8 && < 0.10 + hs-source-dirs: src + ghc-options: -W + + +Test-Suite test + Type: exitcode-stdio-1.0 + Main-is: Tests.hs + hs-source-dirs: testsuite/tests examples + Build-Depends: base >= 4.7, base < 5, template-haskell, mtl, transformers, compdata >= 0.8 && < 0.10, HUnit, + test-framework, test-framework-hunit, containers, compdata-param + +source-repository head + type: git + location: https://github.com/pa-ba/compdata-param diff --git a/compdata-param-master/examples/Examples/Graph.hs b/compdata-param-master/examples/Examples/Graph.hs new file mode 100755 index 0000000..5c84e3c --- /dev/null +++ b/compdata-param-master/examples/Examples/Graph.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TypeOperators, MultiParamTypeClasses, TemplateHaskell, + FlexibleInstances, FlexibleContexts, UndecidableInstances, + OverlappingInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Examples.Param.Graph +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Graph representation. The example is taken from (Fegaras and Sheard, +-- Revisiting Catamorphisms over Datatypes with Embedded Functions, '96). +-- +-------------------------------------------------------------------------------- + +module Examples.Graph where + +import Data.Comp.Param +import Data.Comp.Param.Derive +import Data.Comp.Param.Show () +import Data.Comp.Param.Equality () + +data N p a b = N p [b] -- Node +data R a b = R (a -> b) -- Recursion +data S a b = S (a -> b) b -- Sharing + +$(derive [makeDifunctor, makeShowD, makeEqD, makeOrdD, smartConstructors] + [''N, ''R, ''S]) +$(derive [makeDitraversable] [''N]) + +type Graph p = Term (N p :+: R :+: S) + +class FlatG f p where + flatGAlg :: Alg f [p] + +$(derive [liftSum] [''FlatG]) + +flatG :: (Difunctor f, FlatG f p) => Term f -> [p] +flatG = cata flatGAlg + +instance FlatG (N p) p where + flatGAlg (N p ps) = p : concat ps + +instance FlatG R p where + flatGAlg (R f) = f [] + +instance FlatG S p where + flatGAlg (S f g) = f g + +class SumG f where + sumGAlg :: Alg f Int + +$(derive [liftSum] [''SumG]) + +sumG :: (Difunctor f, SumG f) => Term f -> Int +sumG = cata sumGAlg + +instance SumG (N Int) where + sumGAlg (N p ps) = p + sum ps + +instance SumG R where + sumGAlg (R f) = f 0 + +instance SumG S where + sumGAlg (S f g) = f g + +g :: Graph Int +g = Term $ iR (\x -> iS (\z -> iN (0 :: Int) [z,iR $ \y -> iN (1 :: Int) [y,z]]) + (iN (2 :: Int) [x])) + +f :: [Int] +f = flatG g + +n :: Int +n = sumG g diff --git a/compdata-param-master/examples/Examples/Lambda.hs b/compdata-param-master/examples/Examples/Lambda.hs new file mode 100755 index 0000000..7529079 --- /dev/null +++ b/compdata-param-master/examples/Examples/Lambda.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, + FlexibleInstances, FlexibleContexts, UndecidableInstances, + OverlappingInstances, Rank2Types, GADTs #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Examples.Param.Lambda +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Lambda calculus examples +-- +-- We define a pretty printer, a desugaring transformation, constant folding, +-- and call-by-value interpreter for an extended variant of the simply typed +-- lambda calculus. +-- +-------------------------------------------------------------------------------- + +module Examples.Lambda where + +import Data.Comp.Param +import Data.Comp.Param.Show () +import Data.Comp.Param.Equality () +import Data.Comp.Param.Ordering () +import Data.Comp.Param.Derive +import Data.Comp.Param.Desugar + +data Lam a b = Lam (a -> b) +data App a b = App b b +data Const a b = Const Int +data Plus a b = Plus b b +data Let a b = Let b (a -> b) +data Err a b = Err + +type Sig = Lam :+: App :+: Const :+: Plus :+: Let :+: Err +type Sig' = Lam :+: App :+: Const :+: Plus :+: Err + +$(derive [smartConstructors, makeDifunctor, makeShowD, makeEqD, makeOrdD] + [''Lam, ''App, ''Const, ''Plus, ''Let, ''Err]) + +-- * Pretty printing +data Stream a = Cons a (Stream a) + +class Pretty f where + prettyAlg :: Alg f (Stream String -> String) + +$(derive [liftSum] [''Pretty]) + +pretty :: (Difunctor f, Pretty f) => Term f -> String +pretty t = cata prettyAlg t (nominals 1) + where nominals n = Cons ('x' : show n) (nominals (n + 1)) + +instance Pretty Lam where + prettyAlg (Lam f) (Cons x xs) = "(\\" ++ x ++ ". " ++ f (const x) xs ++ ")" + +instance Pretty App where + prettyAlg (App e1 e2) xs = "(" ++ e1 xs ++ " " ++ e2 xs ++ ")" + +instance Pretty Const where + prettyAlg (Const n) _ = show n + +instance Pretty Plus where + prettyAlg (Plus e1 e2) xs = "(" ++ e1 xs ++ " + " ++ e2 xs ++ ")" + +instance Pretty Err where + prettyAlg Err _ = "error" + +instance Pretty Let where + prettyAlg (Let e1 e2) (Cons x xs) = "let " ++ x ++ " = " ++ e1 xs ++ " in " ++ e2 (const x) xs + +-- * Desugaring +instance (Difunctor f, App :<: f, Lam :<: f) => Desugar Let f where + desugHom' (Let e1 e2) = inject (Lam e2) `iApp` e1 + +-- * Constant folding +class Constf f g where + constfAlg :: forall a. Alg f (Trm g a) + +$(derive [liftSum] [''Constf]) + +constf :: (Difunctor f, Constf f g) => Term f -> Term g +constf t = Term (cata constfAlg t) + +instance (Difunctor f, f :<: g) => Constf f g where + constfAlg = inject . dimap Var id -- default instance + +instance (Plus :<: f, Const :<: f) => Constf Plus f where + constfAlg (Plus e1 e2) = case (project e1, project e2) of + (Just (Const n),Just (Const m)) -> iConst (n + m) + _ -> e1 `iPlus` e2 + +-- * Call-by-value evaluation +data Sem m = Fun (Sem m -> m (Sem m)) | Int Int + +class Monad m => Eval f m where + evalAlg :: Alg f (m (Sem m)) + +$(derive [liftSum] [''Eval]) + +eval :: (Difunctor f, Eval f m) => Term f -> m (Sem m) +eval = cata evalAlg + +instance Monad m => Eval Lam m where + evalAlg (Lam f) = return (Fun (f . return)) + +instance Monad m => Eval App m where + evalAlg (App mx my) = do x <- mx + case x of Fun f -> f =<< my; _ -> fail "stuck" + +instance Monad m => Eval Const m where + evalAlg (Const n) = return (Int n) + +instance Monad m => Eval Plus m where + evalAlg (Plus mx my) = do x <- mx + y <- my + case (x,y) of (Int n,Int m) -> return (Int (n + m)) + _ -> fail "stuck" + +instance Monad m => Eval Err m where + evalAlg Err = fail "error" + +e :: Term Sig +e = Term (iLet (iConst 2) (\x -> (iLam (\y -> y `iPlus` x) `iApp` iConst 3))) + +e' :: Term Sig' +e' = desugar e + +evalEx :: Maybe (Sem Maybe) +evalEx = eval e' diff --git a/compdata-param-master/examples/Examples/Multi/FOL.hs b/compdata-param-master/examples/Examples/Multi/FOL.hs new file mode 100755 index 0000000..c7aa331 --- /dev/null +++ b/compdata-param-master/examples/Examples/Multi/FOL.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators, FlexibleInstances, + FlexibleContexts, UndecidableInstances, GADTs, KindSignatures, + OverlappingInstances, TypeSynonymInstances, EmptyDataDecls #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Examples.MultiParam.FOL +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- First-Order Logic a la Carte +-- +-- This example illustrates how to implement First-Order Logic a la Carte +-- (Knowles, The Monad.Reader Issue 11, '08) using Generalised Parametric +-- Compositional Data Types. +-- +-- Rather than using a fixed domain 'Term' for binders as Knowles, our encoding +-- uses a mutually recursive data structure for terms and formulae. This makes +-- terms modular too, and hence we only introduce variables when they are +-- actually needed in stage 5. +-- +-------------------------------------------------------------------------------- + +module Examples.Multi.FOL where + +import Data.Comp.Param.Multi hiding (Var) +import qualified Data.Comp.Param.Multi as MP +import Data.Comp.Param.Multi.Show () +import Data.Comp.Param.Multi.Derive +import Data.Comp.Param.Multi.FreshM (Name, withName, evalFreshM) +import Data.List (intercalate) +import Data.Maybe +import Control.Monad.State +import Control.Monad.Reader + +-- Phantom types indicating whether a (recursive) term is a formula or a term +data TFormula +data TTerm + +-- Terms +data Const :: (* -> *) -> (* -> *) -> * -> * where + Const :: String -> [e TTerm] -> Const a e TTerm +data Var :: (* -> *) -> (* -> *) -> * -> * where + Var :: String -> Var a e TTerm + +-- Formulae +data TT :: (* -> *) -> (* -> *) -> * -> * where + TT :: TT a e TFormula +data FF :: (* -> *) -> (* -> *) -> * -> * where + FF :: FF a e TFormula +data Atom :: (* -> *) -> (* -> *) -> * -> * where + Atom :: String -> [e TTerm] -> Atom a e TFormula +data NAtom :: (* -> *) -> (* -> *) -> * -> * where + NAtom :: String -> [e TTerm] -> NAtom a e TFormula +data Not :: (* -> *) -> (* -> *) -> * -> * where + Not :: e TFormula -> Not a e TFormula +data Or :: (* -> *) -> (* -> *) -> * -> * where + Or :: e TFormula -> e TFormula -> Or a e TFormula +data And :: (* -> *) -> (* -> *) -> * -> * where + And :: e TFormula -> e TFormula -> And a e TFormula +data Impl :: (* -> *) -> (* -> *) -> * -> * where + Impl :: e TFormula -> e TFormula -> Impl a e TFormula +data Exists :: (* -> *) -> (* -> *) -> * -> * where + Exists :: (a TTerm -> e TFormula) -> Exists a e TFormula +data Forall :: (* -> *) -> (* -> *) -> * -> * where + Forall :: (a TTerm -> e TFormula) -> Forall a e TFormula + +$(derive [makeHDifunctor, smartConstructors] + [''Const, ''Var, ''TT, ''FF, ''Atom, ''NAtom, + ''Not, ''Or, ''And, ''Impl, ''Exists, ''Forall]) + +-------------------------------------------------------------------------------- +-- (Custom) pretty printing of terms and formulae +-------------------------------------------------------------------------------- + +instance ShowHD Const where + showHD (Const f t) = do ts <- mapM unK t + return $ f ++ "(" ++ intercalate ", " ts ++ ")" + +instance ShowHD Var where + showHD (Var x) = return x + +instance ShowHD TT where + showHD TT = return "true" + +instance ShowHD FF where + showHD FF = return "false" + +instance ShowHD Atom where + showHD (Atom p t) = do ts <- mapM unK t + return $ p ++ "(" ++ intercalate ", " ts ++ ")" + +instance ShowHD NAtom where + showHD (NAtom p t) = do ts <- mapM unK t + return $ "not " ++ p ++ "(" ++ intercalate ", " ts ++ ")" + +instance ShowHD Not where + showHD (Not (K f)) = liftM (\x -> "not (" ++ x ++ ")") f + +instance ShowHD Or where + showHD (Or (K f1) (K f2)) = + liftM2 (\x y -> "(" ++ x ++ ") or (" ++ y ++ ")") f1 f2 + +instance ShowHD And where + showHD (And (K f1) (K f2)) = + liftM2 (\x y -> "(" ++ x ++ ") and (" ++ y ++ ")") f1 f2 + +instance ShowHD Impl where + showHD (Impl (K f1) (K f2)) = + liftM2 (\x y -> "(" ++ x ++ ") -> (" ++ y ++ ")") f1 f2 + +instance ShowHD Exists where + showHD (Exists f) = + withName (\x -> do b <- unK (f x) + return $ "exists " ++ show x ++ ". " ++ b) + +instance ShowHD Forall where + showHD (Forall f) = + withName (\x -> do b <- unK (f x) + return $ "forall " ++ show x ++ ". " ++ b) + +-------------------------------------------------------------------------------- +-- Stage 0 +-------------------------------------------------------------------------------- + +type Input = Const :+: + TT :+: FF :+: Atom :+: Not :+: Or :+: And :+: Impl :+: + Exists :+: Forall + +foodFact :: Term Input TFormula +foodFact = Term $ + iExists (\p -> iAtom "Person" [p] `iAnd` + iForall (\f -> iAtom "Food" [f] `iImpl` + iAtom "Eats" [p,f])) `iImpl` + iNot (iExists $ \f -> iAtom "Food" [f] `iAnd` + iNot (iExists $ \p -> iAtom "Person" [p] `iAnd` + iAtom "Eats" [p,f])) + +-------------------------------------------------------------------------------- +-- Stage 1: Eliminate Implications +-------------------------------------------------------------------------------- + +type Stage1 = Const :+: + TT :+: FF :+: Atom :+: Not :+: Or :+: And :+: Exists :+: Forall + +class HDifunctor f => ElimImp f where + elimImpHom :: Hom f Stage1 + +$(derive [liftSum] [''ElimImp]) + +elimImp :: Term Input :-> Term Stage1 +elimImp (Term t) = Term (appHom elimImpHom t) + +instance (HDifunctor f, f :<: Stage1) => ElimImp f where + elimImpHom = simpCxt . inj + +instance ElimImp Impl where + elimImpHom (Impl f1 f2) = iNot (Hole f1) `iOr` (Hole f2) + +foodFact1 :: Term Stage1 TFormula +foodFact1 = elimImp foodFact + +-------------------------------------------------------------------------------- +-- Stage 2: Move Negation Inwards +-------------------------------------------------------------------------------- + +type Stage2 = Const :+: + TT :+: FF :+: Atom :+: NAtom :+: Or :+: And :+: Exists :+: Forall + +class HDifunctor f => Dualize f where + dualizeHom :: f a (Cxt h Stage2 a b) :-> Cxt h Stage2 a b + +$(derive [liftSum] [''Dualize]) + +dualize :: Trm Stage2 a :-> Trm Stage2 a +dualize = appHom (dualizeHom . hfmap Hole) + +instance Dualize Const where + dualizeHom (Const f t) = iConst f t + +instance Dualize TT where + dualizeHom TT = iFF + +instance Dualize FF where + dualizeHom FF = iTT + +instance Dualize Atom where + dualizeHom (Atom p t) = iNAtom p t + +instance Dualize NAtom where + dualizeHom (NAtom p t) = iAtom p t + +instance Dualize Or where + dualizeHom (Or f1 f2) = f1 `iAnd` f2 + +instance Dualize And where + dualizeHom (And f1 f2) = f1 `iOr` f2 + +instance Dualize Exists where + dualizeHom (Exists f) = inject $ Forall f + +instance Dualize Forall where + dualizeHom (Forall f) = inject $ Exists f + +class PushNot f where + pushNotAlg :: Alg f (Trm Stage2 a) + +$(derive [liftSum] [''PushNot]) + +pushNotInwards :: Term Stage1 :-> Term Stage2 +pushNotInwards t = Term (cata pushNotAlg t) + +instance (HDifunctor f, f :<: Stage2) => PushNot f where + pushNotAlg = inject . hdimap MP.Var id -- default + +instance PushNot Not where + pushNotAlg (Not f) = dualize f + +foodFact2 :: Term Stage2 TFormula +foodFact2 = pushNotInwards foodFact1 + +-------------------------------------------------------------------------------- +-- Stage 4: Skolemization +-------------------------------------------------------------------------------- + +type Stage4 = Const :+: + TT :+: FF :+: Atom :+: NAtom :+: Or :+: And :+: Forall + +type Unique = Int +data UniqueSupply = UniqueSupply Unique UniqueSupply UniqueSupply + +initialUniqueSupply :: UniqueSupply +initialUniqueSupply = genSupply 1 + where genSupply n = UniqueSupply n (genSupply (2 * n)) + (genSupply (2 * n + 1)) + +splitUniqueSupply :: UniqueSupply -> (UniqueSupply, UniqueSupply) +splitUniqueSupply (UniqueSupply _ l r) = (l,r) + +getUnique :: UniqueSupply -> (Unique, UniqueSupply) +getUnique (UniqueSupply n l _) = (n,l) + +type Supply = State UniqueSupply +type S a = ReaderT [Trm Stage4 a TTerm] Supply + +evalS :: S a b -> [Trm Stage4 a TTerm] -> UniqueSupply -> b +evalS m env = evalState (runReaderT m env) + +fresh :: S a Int +fresh = do supply <- get + let (uniq,rest) = getUnique supply + put rest + return uniq + +freshes :: S a UniqueSupply +freshes = do supply <- get + let (l,r) = splitUniqueSupply supply + put r + return l + +class Skolem f where + skolemAlg :: AlgM' (S a) f (Trm Stage4 a) + +$(derive [liftSum] [''Skolem]) + +skolemize :: Term Stage2 :-> Term Stage4 +skolemize f = Term (evalState (runReaderT (cataM' skolemAlg f) []) + initialUniqueSupply) + +instance Skolem Const where + skolemAlg (Const f t) = liftM (iConst f) $ mapM getCompose t + +instance Skolem TT where + skolemAlg TT = return iTT + +instance Skolem FF where + skolemAlg FF = return iFF + +instance Skolem Atom where + skolemAlg (Atom p t) = liftM (iAtom p) $ mapM getCompose t + +instance Skolem NAtom where + skolemAlg (NAtom p t) = liftM (iNAtom p) $ mapM getCompose t + +instance Skolem Or where + skolemAlg (Or (Compose f1) (Compose f2)) = liftM2 iOr f1 f2 + +instance Skolem And where + skolemAlg (And (Compose f1) (Compose f2)) = liftM2 iAnd f1 f2 + +instance Skolem Forall where + skolemAlg (Forall f) = do + supply <- freshes + xs <- ask + return $ iForall $ \x -> evalS (getCompose $ f x) (x : xs) supply + +instance Skolem Exists where + skolemAlg (Exists f) = do + uniq <- fresh + xs <- ask + getCompose $ f (iConst ("Skol" ++ show uniq) xs) + +foodFact4 :: Term Stage4 TFormula +foodFact4 = skolemize foodFact2 + +-------------------------------------------------------------------------------- +-- Stage 5: Prenex Normal Form +-------------------------------------------------------------------------------- + +type Stage5 = Const :+: Var :+: + TT :+: FF :+: Atom :+: NAtom :+: Or :+: And + +class Prenex f where + prenexAlg :: AlgM' (S a) f (Trm Stage5 a) + +$(derive [liftSum] [''Prenex]) + +prenex :: Term Stage4 :-> Term Stage5 +prenex f = Term (evalState (runReaderT (cataM' prenexAlg f) []) + initialUniqueSupply) + +instance Prenex Const where + prenexAlg (Const f t) = liftM (iConst f) $ mapM getCompose t + +instance Prenex TT where + prenexAlg TT = return iTT + +instance Prenex FF where + prenexAlg FF = return iFF + +instance Prenex Atom where + prenexAlg (Atom p t) = liftM (iAtom p) $ mapM getCompose t + +instance Prenex NAtom where + prenexAlg (NAtom p t) = liftM (iNAtom p) $ mapM getCompose t + +instance Prenex Or where + prenexAlg (Or (Compose f1) (Compose f2)) = liftM2 iOr f1 f2 + +instance Prenex And where + prenexAlg (And (Compose f1) (Compose f2)) = liftM2 iAnd f1 f2 + +instance Prenex Forall where + prenexAlg (Forall f) = do uniq <- fresh + getCompose $ f (iVar ('x' : show uniq)) + +foodFact5 :: Term Stage5 TFormula +foodFact5 = prenex foodFact4 + +-------------------------------------------------------------------------------- +-- Stage 6: Conjunctive Normal Form +-------------------------------------------------------------------------------- + +type Literal a = Trm (Const :+: Var :+: Atom :+: NAtom) a +newtype Clause a i = Clause {unClause :: [Literal a i]} -- implicit disjunction +newtype CNF a i = CNF {unCNF :: [Clause a i]} -- implicit conjunction + +instance (HDifunctor f, ShowHD f) => Show (Trm f Name i) where + show = evalFreshM . showHD . toCxt + +instance Show (Clause Name i) where + show c = intercalate " or " $ map show $ unClause c + +instance Show (CNF Name i) where + show c = intercalate "\n" $ map show $ unCNF c + +class ToCNF f where + cnfAlg :: f (CNF a) (CNF a) i -> [Clause a i] + +$(derive [liftSum] [''ToCNF]) + +cnf :: Term Stage5 :-> CNF a +cnf = cata (CNF . cnfAlg) + +instance ToCNF Const where + cnfAlg (Const f t) = + [Clause [iConst f (map (head . unClause . head . unCNF) t)]] + +instance ToCNF Var where + cnfAlg (Var x) = [Clause [iVar x]] + +instance ToCNF TT where + cnfAlg TT = [] + +instance ToCNF FF where + cnfAlg FF = [Clause []] + +instance ToCNF Atom where + cnfAlg (Atom p t) = + [Clause [iAtom p (map (head . unClause . head . unCNF) t)]] + +instance ToCNF NAtom where + cnfAlg (NAtom p t) = + [Clause [iNAtom p (map (head . unClause . head . unCNF) t)]] + +instance ToCNF And where + cnfAlg (And f1 f2) = unCNF f1 ++ unCNF f2 + +instance ToCNF Or where + cnfAlg (Or f1 f2) = + [Clause (x ++ y) | Clause x <- unCNF f1, Clause y <- unCNF f2] + +foodFact6 :: CNF a TFormula +foodFact6 = cnf foodFact5 + +-------------------------------------------------------------------------------- +-- Stage 7: Implicative Normal Form +-------------------------------------------------------------------------------- + +type T = Const :+: Var :+: Atom :+: NAtom +newtype IClause a i = IClause ([Trm T a i], -- implicit conjunction + [Trm T a i]) -- implicit disjunction +newtype INF a i = INF [IClause a i] -- implicit conjunction + +instance Show (IClause Name i) where + show (IClause (cs,ds)) = let cs' = intercalate " and " $ map show cs + ds' = intercalate " or " $ map show ds + in "(" ++ cs' ++ ") -> (" ++ ds' ++ ")" + +instance Show (INF Name i) where + show (INF fs) = intercalate "\n" $ map show fs + +inf :: CNF a TFormula -> INF a TFormula +inf (CNF f) = INF $ map (toImpl . unClause) f + where toImpl :: [Literal a TFormula] -> IClause a TFormula + toImpl disj = IClause ([iAtom p t | NAtom p t <- mapMaybe proj1 disj], + [inject t | t <- mapMaybe proj2 disj]) + proj1 :: NatM Maybe (Trm T a) (NAtom a (Trm T a)) + proj1 = project + proj2 :: NatM Maybe (Trm T a) (Atom a (Trm T a)) + proj2 = project + +foodFact7 :: INF a TFormula +foodFact7 = inf foodFact6 diff --git a/compdata-param-master/examples/Examples/Multi/Lambda.hs b/compdata-param-master/examples/Examples/Multi/Lambda.hs new file mode 100755 index 0000000..56511ca --- /dev/null +++ b/compdata-param-master/examples/Examples/Multi/Lambda.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, + FlexibleInstances, FlexibleContexts, UndecidableInstances, + OverlappingInstances, Rank2Types, GADTs, KindSignatures, + ScopedTypeVariables, TypeFamilies #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Examples.MultiParam.Lambda +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Tagless (monadic) interpretation of extended lambda calculus +-- +-------------------------------------------------------------------------------- + +module Examples.Multi.Lambda where + +import Data.Comp.Param.Multi +import Data.Comp.Param.Multi.Show () +import Data.Comp.Param.Multi.Equality () +import Data.Comp.Param.Multi.Derive +import Control.Monad (liftM2) +import Control.Monad.Error (MonadError, throwError) + +data Lam :: (* -> *) -> (* -> *) -> * -> * where + Lam :: (a i -> b j) -> Lam a b (i -> j) +data App :: (* -> *) -> (* -> *) -> * -> * where + App :: b (i -> j) -> b i -> App a b j +data Const :: (* -> *) -> (* -> *) -> * -> * where + Const :: Int -> Const a b Int +data Plus :: (* -> *) -> (* -> *) -> * -> * where + Plus :: b Int -> b Int -> Plus a b Int +data Err :: (* -> *) -> (* -> *) -> * -> * where + Err :: Err a b i +type Sig = Lam :+: App :+: Const :+: Plus :+: Err + +$(derive [smartConstructors, makeHDifunctor, makeShowHD, makeEqHD] + [''Lam, ''App, ''Const, ''Plus, ''Err]) + +-- * Tagless interpretation +class Eval f where + evalAlg :: f I I i -> i -- I . evalAlg :: Alg f I is the actual algebra + +$(derive [liftSum] [''Eval]) + +eval :: (HDifunctor f, Eval f) => Term f i -> i +eval = unI . cata (I . evalAlg) + +instance Eval Lam where + evalAlg (Lam f) = unI . f . I + +instance Eval App where + evalAlg (App (I f) (I x)) = f x + +instance Eval Const where + evalAlg (Const n) = n + +instance Eval Plus where + evalAlg (Plus (I x) (I y)) = x + y + +instance Eval Err where + evalAlg Err = error "error" + +-- * Tagless monadic interpretation +type family Sem (m :: * -> *) i +type instance Sem m (i -> j) = Sem m i -> m (Sem m j) +type instance Sem m Int = Int + +newtype M m i = M {unM :: m (Sem m i)} + +class Monad m => EvalM m f where + evalMAlg :: f (M m) (M m) i -> m (Sem m i) -- M . evalMAlg :: Alg f (M m) + +$(derive [liftSum] [''EvalM]) + +evalM :: (Monad m, HDifunctor f, EvalM m f) => Term f i -> m (Sem m i) +evalM = unM . cata (M . evalMAlg) + +instance Monad m => EvalM m Lam where + evalMAlg (Lam f) = return $ unM . f . M . return + +instance Monad m => EvalM m App where + evalMAlg (App (M mf) (M mx)) = do f <- mf; f =<< mx + +instance Monad m => EvalM m Const where + evalMAlg (Const n) = return n + +instance Monad m => EvalM m Plus where + evalMAlg (Plus (M mx) (M my)) = liftM2 (+) mx my + +instance MonadError String m => EvalM m Err where + evalMAlg Err = throwError "error" -- 'throwError' rather than 'error' + +e :: Term Sig Int +e = Term ((iLam $ \x -> (iLam (\y -> y `iPlus` x) `iApp` iConst 3)) `iApp` iConst 2) + +v :: Either String Int +v = evalM e + +e' :: Term Sig (Int -> Int) +e' = Term iErr --(iLam id) + +v' :: Either String (Int -> Either String Int) +v' = evalM e' diff --git a/compdata-param-master/examples/Examples/Names.hs b/compdata-param-master/examples/Examples/Names.hs new file mode 100755 index 0000000..802c5c2 --- /dev/null +++ b/compdata-param-master/examples/Examples/Names.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, + FlexibleInstances, FlexibleContexts, UndecidableInstances, + OverlappingInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Examples.Param.Names +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- From names to parametric higher-order abstract syntax and back +-- +-- The example illustrates how to convert a parse tree with explicit names into +-- an AST that uses parametric higher-order abstract syntax, and back again. The +-- example shows how we can easily convert object language binders to Haskell +-- binders, without having to worry about capture avoidance. +-- +-------------------------------------------------------------------------------- + +module Examples.Names where + +import Data.Comp.Param hiding (Var) +import qualified Data.Comp.Param as P +import Data.Comp.Param.Derive +import Data.Comp.Param.Ditraversable +import Data.Comp.Param.Show () +import Data.Maybe +import qualified Data.Map as Map +import Control.Monad.Reader + +data Lam a b = Lam (a -> b) +data App a b = App b b +data Lit a b = Lit Int +data Plus a b = Plus b b +type Name = String -- The type of names +data NLam a b = NLam Name b +data NVar a b = NVar Name +type SigB = App :+: Lit :+: Plus +type SigN = NLam :+: NVar :+: SigB -- The name signature +type SigP = Lam :+: SigB -- The PHOAS signature + +$(derive [makeDifunctor, makeShowD, makeEqD, smartConstructors] + [''Lam, ''App, ''Lit, ''Plus, ''NLam, ''NVar]) +$(derive [makeDitraversable] + [''App, ''Lit, ''Plus, ''NLam, ''NVar]) + +-------------------------------------------------------------------------------- +-- Names to PHOAS translation +-------------------------------------------------------------------------------- + +type M f a = Reader (Map.Map Name (Trm f a)) + +class N2PTrans f g where + n2pAlg :: Alg f (M g a (Trm g a)) + + +-- We make the lifting to sums explicit in order to make the N2PTrans +-- work with the default instance declaration further below. +instance (N2PTrans f1 g, N2PTrans f2 g) => N2PTrans (f1 :+: f2) g where + n2pAlg = caseD n2pAlg n2pAlg + +n2p :: (Difunctor f, N2PTrans f g) => Term f -> Term g +n2p t = Term $ runReader (cata n2pAlg t) Map.empty + +instance (Lam :<: g) => N2PTrans NLam g where + n2pAlg (NLam x b) = do vars <- ask + return $ iLam $ \y -> runReader b (Map.insert x y vars) + +instance (Ditraversable f, f :<: g) => N2PTrans f g where + n2pAlg = liftM inject . disequence . dimap (return . P.Var) id -- default + +instance N2PTrans NVar g where + n2pAlg (NVar x) = liftM fromJust (asks (Map.lookup x)) + +en :: Term SigN +en = Term $ iNLam "x1" $ iNLam "x2" (iNLam "x3" $ iNVar "x2") `iApp` iNVar "x1" + +ep :: Term SigP +ep = n2p en + +-------------------------------------------------------------------------------- +-- PHOAS to names translation +-------------------------------------------------------------------------------- + +type M' = Reader [Name] + +class P2NTrans f g where + p2nAlg :: Alg f (M' (Trm g a)) + + +-- We make the lifting to sums explicit in order to make the P2NTrans +-- work with the default instance declaration further below. +instance (P2NTrans f1 g, P2NTrans f2 g) => P2NTrans (f1 :+: f2) g where + p2nAlg = caseD p2nAlg p2nAlg + + +p2n :: (Difunctor f, P2NTrans f g) => Term f -> Term g +p2n t = Term $ runReader (cata p2nAlg t) ['x' : show n | n <- [1..]] + +instance (Ditraversable f, f :<: g) => P2NTrans f g where + p2nAlg = liftM inject . disequence . dimap (return . P.Var) id -- default + +instance (NLam :<: g, NVar :<: g) => P2NTrans Lam g where + p2nAlg (Lam f) = do n:names <- ask + return $ iNLam n (runReader (f (return $ iNVar n)) names) + +ep' :: Term SigP +ep' = Term $ iLam $ \a -> iLam (\b -> (iLam $ \_ -> b)) `iApp` a + +en' :: Term SigN +en' = p2n ep' diff --git a/compdata-param-master/examples/Examples/Thunk.hs b/compdata-param-master/examples/Examples/Thunk.hs new file mode 100755 index 0000000..c332ef3 --- /dev/null +++ b/compdata-param-master/examples/Examples/Thunk.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, + FlexibleInstances, FlexibleContexts, UndecidableInstances, OverlappingInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Examples.Param.Thunk +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Patrick Bahr +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-------------------------------------------------------------------------------- + +module Examples.Thunk where + +import Data.Comp.Param +import Data.Comp.Param.Show () +import Data.Comp.Param.Derive +import Data.Comp.Param.Thunk + +-- Signatures for values and operators +data Const a e = Const Int +data Lam a e = Lam (a -> e) -- Note: not e -> e +data App a e = App e e +data Op a e = Add e e | Mult e e +data Fun a e = Fun (e -> e) -- Note: not a -> e + +-- Signature for the simple expression language +type Sig = Const :+: Lam :+: App :+: Op +-- Signature for values. Note the use of 'FunM' rather than 'Lam' (!) +type Value = Const :+: Fun +-- Signature for ground values. +type GValue = Const + +-- Derive boilerplate code using Template Haskell +$(derive [makeDifunctor, makeEqD, makeOrdD, makeShowD, smartConstructors] + [''Const, ''Lam, ''App, ''Op]) +$(derive [makeDitraversable] + [''Const, ''App, ''Op]) + +-- Term evaluation algebra. Note that we cannot use @AlgM Maybe f (Term v)@ +-- because that would force @FunM@ to have the type @e -> e@ rather than +-- @e -> m e@. The latter is needed because the input to a @Lam@ (which is +-- evaluated to a @Fun@) will determine whether or not an error should be +-- returned. Example: @(\x -> x x) 42@ will produce an error because the +-- abstraction is applied to a non-functional, whereas @(\x -> x x)(\y -> y)@ +-- will not. +class EvalT f v where + evalAlgT :: Alg f (TrmT Maybe v a) + +$(derive [liftSum] [''EvalT]) + +-- Lift the evaluation algebra to a catamorphism +evalT :: (Difunctor f, Ditraversable v, EvalT f v) => Term f -> Maybe (Term v) +evalT t = nfT $ Term (cata evalAlgT t) + +-- instance (Ditraversable f Maybe Any, f :<: v) => EvalT f v where +-- evalAlgT = strict' + +instance (Difunctor f, f :<: v) => EvalT f v where + evalAlgT = inject' + + +instance (Const :<: v) => EvalT Op v where + evalAlgT (Add mx my) = thunk $ do + Const x <- whnfPr mx + Const y <- whnfPr my + return $ iConst $ x + y + evalAlgT (Mult mx my) = thunk $ do + Const x <- whnfPr mx + Const y <- whnfPr my + return $ iConst $ x * y + +instance (Fun :<: v) => EvalT App v where + evalAlgT (App mx my) = thunk $ do + Fun f <- whnfPr mx + -- lazy + return $ f my + -- strict + -- liftM f $ whnf' my + +instance (Fun :<: v) => EvalT Lam v where + evalAlgT (Lam f) = inject $ Fun f + +-- |Evaluation of expressions to ground values. +evalMG :: Term Sig -> Maybe (Term GValue) +evalMG e = termM $ nfPr $ eval e + where eval :: Term Sig -> TrmT Maybe Value a + eval = cata evalAlgT + + +-- Example: evalEx = Just (iConst 12) (3 * (2 + 2) = 12) +evalMEx :: Maybe (Term GValue) +evalMEx = evalMG $ Term $ iLam (\x -> iLam $ \y -> y `iMult` (x `iAdd` x)) + `iApp` iConst 2 `iApp` iConst 3 + +-- Example: type error +evalMEx' :: Maybe (Term GValue) +evalMEx' = evalMG $ Term $ iLam (\x -> iLam $ \y -> x `iMult` (x `iAdd` x)) + `iApp` iConst 2 `iApp` (iLam (\x -> x) `iAdd` iConst 2) + +-- Example: non-termination +evalMExY :: Maybe (Term GValue) +evalMExY = evalMG $ Term $ iLam (\x -> iLam $ \y -> x `iMult` (x `iAdd` x)) + `iApp` iConst 2 `iApp` omega + where omega = iLam (\x -> x `iApp` x) `iApp` iLam (\x -> x `iApp` x) diff --git a/compdata-param-master/src/Data/Comp/Param.hs b/compdata-param-master/src/Data/Comp/Param.hs new file mode 100755 index 0000000..4baedb0 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param.hs @@ -0,0 +1,32 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Patrick Bahr , Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines the infrastructure necessary to use +-- /Parametric Compositional Data Types/. Parametric Compositional Data Types +-- is an extension of Compositional Data Types with parametric +-- higher-order abstract syntax (PHOAS) for usage with binders. Examples of +-- usage are bundled with the package in the library +-- @examples\/Examples\/Param@. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param ( + module Data.Comp.Param.Term + , module Data.Comp.Param.Algebra + , module Data.Comp.Param.Difunctor + , module Data.Comp.Param.Sum + , module Data.Comp.Param.Annotation + , module Data.Comp.Param.Equality + ) where + +import Data.Comp.Param.Term +import Data.Comp.Param.Algebra +import Data.Comp.Param.Difunctor +import Data.Comp.Param.Sum +import Data.Comp.Param.Annotation +import Data.Comp.Param.Equality \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Algebra.hs b/compdata-param-master/src/Data/Comp/Param/Algebra.hs new file mode 100755 index 0000000..75a7664 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Algebra.hs @@ -0,0 +1,962 @@ +{-# LANGUAGE GADTs, Rank2Types, ScopedTypeVariables, TypeOperators, + FlexibleContexts, CPP #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Algebra +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines the notion of algebras and catamorphisms, and their +-- generalizations to e.g. monadic versions and other (co)recursion schemes. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Algebra ( + -- * Algebras & Catamorphisms + Alg, + free, + cata, + cata', + appCxt, + + -- * Monadic Algebras & Catamorphisms + AlgM, + algM, + freeM, + cataM, + cataM', + + -- * Term Homomorphisms + CxtFun, + SigFun, + Hom, + appHom, + appHom', + compHom, + appSigFun, + appSigFun', + compSigFun, + compHomSigFun, + compSigFunHom, + hom, + compAlg, + compAlgSigFun, + + -- * Monadic Term Homomorphisms + CxtFunM, + SigFunM, + HomM, + SigFunMD, + HomMD, + sigFunM, + appHomM, + appTHomM, + appHomM', + appTHomM', + homM, + homMD, + appSigFunM, + appTSigFunM, + appSigFunM', + appTSigFunM', + appSigFunMD, + appTSigFunMD, + compHomM, + compHomM', + compSigFunM, + compSigFunHomM, + compSigFunHomM', + compAlgSigFunM, + compAlgSigFunM', + compAlgM, + compAlgM', + + -- * Coalgebras & Anamorphisms + Coalg, + ana, + CoalgM, + anaM, + + -- * R-Algebras & Paramorphisms + RAlg, + para, + RAlgM, + paraM, + + -- * R-Coalgebras & Apomorphisms + RCoalg, + apo, + RCoalgM, + apoM, + + -- * CV-Algebras & Histomorphisms + CVAlg, + histo, + CVAlgM, + histoM, + + -- * CV-Coalgebras & Futumorphisms + CVCoalg, + futu, + CVCoalg', + futu', + CVCoalgM, + futuM + ) where + +import Prelude hiding (sequence, mapM) +import Control.Monad hiding (sequence, mapM) +import Data.Comp.Param.Term +import Data.Comp.Param.Ops +import Data.Comp.Param.Difunctor +import Data.Comp.Param.Ditraversable + +{-| This type represents an algebra over a difunctor @f@ and carrier @a@. -} +type Alg f a = f a a -> a + + +{-| Construct a catamorphism for contexts over @f@ with holes of type @b@, from + the given algebra. -} +free :: forall h f a b. Difunctor f + => Alg f a -> (b -> a) -> Cxt h f a b -> a +free f g = run + where run :: Cxt h f a b -> a + run (In t) = f (difmap run t) + run (Hole x) = g x + run (Var p) = p + +{-| Construct a catamorphism from the given algebra. -} +cata :: forall f a. Difunctor f => Alg f a -> Term f -> a +{-# NOINLINE [1] cata #-} +cata f (Term t) = run t + where run :: Trm f a -> a + run (In t) = f (difmap run t) + run (Var x) = x + +{-| A generalisation of 'cata' from terms over @f@ to contexts over @f@, where + the holes have the type of the algebra carrier. -} +cata' :: Difunctor f => Alg f a -> Cxt h f a a -> a +{-# INLINE cata' #-} +cata' f = free f id + +{-| This function applies a whole context into another context. -} +appCxt :: Difunctor f => Context f a (Cxt h f a b) -> Cxt h f a b +appCxt (In t) = In (difmap appCxt t) +appCxt (Hole x) = x +appCxt (Var p) = Var p + +{-| This type represents a monadic algebra. It is similar to 'Alg' but + the return type is monadic. -} +type AlgM m f a = f a a -> m a + +{-| Convert a monadic algebra into an ordinary algebra with a monadic + carrier. -} +algM :: (Ditraversable f, Monad m) => AlgM m f a -> Alg f (m a) +algM f x = disequence (dimap return id x) >>= f + +{-| Construct a monadic catamorphism for contexts over @f@ with holes of type + @b@, from the given monadic algebra. -} +freeM :: forall m h f a b. (Ditraversable f, Monad m) + => AlgM m f a -> (b -> m a) -> Cxt h f a b -> m a +freeM f g = run + where run :: Cxt h f a b -> m a + run (In t) = f =<< dimapM run t + run (Hole x) = g x + run (Var p) = return p + +{-| Construct a monadic catamorphism from the given monadic algebra. -} +cataM :: forall m f a. (Ditraversable f, Monad m) => AlgM m f a -> Term f -> m a +{-# NOINLINE [1] cataM #-} +cataM algm (Term t) = run t + where run :: Trm f a -> m a + run (In t) = algm =<< dimapM run t + run (Var x) = return x + +{-| A generalisation of 'cataM' from terms over @f@ to contexts over @f@, where + the holes have the type of the monadic algebra carrier. -} +cataM' :: forall m h f a. (Ditraversable f, Monad m) + => AlgM m f a -> Cxt h f a (m a) -> m a +{-# NOINLINE [1] cataM' #-} +cataM' f = freeM f id + +{-| This type represents a context function. -} +type CxtFun f g = forall h a b. Cxt h f a b -> Cxt h g a b + + +{-| This type represents a signature function. -} +type SigFun f g = forall a b. f a b -> g a b + +{-| This type represents a term homomorphism. -} +type Hom f g = SigFun f (Context g) + +{-| Apply a term homomorphism recursively to a term/context. -} +appHom :: forall f g. (Difunctor f, Difunctor g) => Hom f g -> CxtFun f g +{-# NOINLINE [1] appHom #-} +appHom f = run where + run :: CxtFun f g + run (In t) = appCxt (f (difmap run t)) + run (Hole x) = Hole x + run (Var p) = Var p + +{-| Apply a term homomorphism recursively to a term/context. -} +appHom' :: forall f g. (Difunctor g) => Hom f g -> CxtFun f g +{-# NOINLINE [1] appHom' #-} +appHom' f = run where + run :: CxtFun f g + run (In t) = appCxt (fmapCxt run (f t)) + run (Hole x) = Hole x + run (Var p) = Var p + +fmapCxt :: Difunctor f => (b -> b') -> Cxt h f a b -> Cxt h f a b' +fmapCxt f = run + where run (In t) = In $ difmap run t + run (Var a) = Var a + run (Hole b) = Hole $ f b + +{-| Compose two term homomorphisms. -} +compHom :: (Difunctor g, Difunctor h) + => Hom g h -> Hom f g -> Hom f h +compHom f g = appHom f . g + + +{-| Compose an algebra with a term homomorphism to get a new algebra. -} +compAlg :: (Difunctor f, Difunctor g) => Alg g a -> Hom f g -> Alg f a +compAlg alg talg = cata' alg . talg + +compAlgSigFun :: Alg g a -> SigFun f g -> Alg f a +compAlgSigFun alg sig = alg . sig + + +{-| This function applies a signature function to the given context. -} +appSigFun :: forall f g. (Difunctor f) => SigFun f g -> CxtFun f g +{-# NOINLINE [1] appSigFun #-} +appSigFun f = run + where run (In t) = In $ f $ difmap run t + run (Var x) = Var x + run (Hole x) = Hole x +-- implementation via term homomorphisms +-- appSigFun f = appHom $ hom f + + +-- | This function applies a signature function to the given +-- context. This is a top-bottom variant of 'appSigFun'. +appSigFun' :: forall f g. (Difunctor g) => SigFun f g -> CxtFun f g +{-# NOINLINE [1] appSigFun' #-} +appSigFun' f = run + where run (In t) = In $ difmap run $ f t + run (Var x) = Var x + run (Hole x) = Hole x + +{-| This function composes two signature functions. -} +compSigFun :: SigFun g h -> SigFun f g -> SigFun f h +compSigFun f g = f . g + +{-| This function composes a term homomorphism and a signature function. -} +compHomSigFun :: Hom g h -> SigFun f g -> Hom f h +compHomSigFun f g = f . g + +{-| This function composes a term homomorphism and a signature function. -} +compSigFunHom :: (Difunctor g) => SigFun g h -> Hom f g -> Hom f h +compSigFunHom f g = appSigFun f . g + + +{-| Lifts the given signature function to the canonical term homomorphism. -} +hom :: Difunctor g => SigFun f g -> Hom f g +hom f = simpCxt . f + +{-| This type represents a monadic signature function. -} +type SigFunM m f g = forall a b. f a b -> m (g a b) + +{-| This type represents a monadic context function. -} +type CxtFunM m f g = forall h . SigFunM m (Cxt h f) (Cxt h g) + +{-| This type represents a monadic signature function. It is similar to + 'SigFunM' but has monadic values also in the domain. -} +type SigFunMD m f g = forall a b. f a (m b) -> m (g a b) + +{-| This type represents a monadic term homomorphism. -} +type HomM m f g = SigFunM m f (Context g) + +{-| This type represents a monadic term homomorphism. It is similar to + 'HomM' but has monadic values also in the domain. -} +type HomMD m f g = SigFunMD m f (Context g) + +{-| Lift the given signature function to a monadic signature function. Note that + term homomorphisms are instances of signature functions. Hence this function + also applies to term homomorphisms. -} +sigFunM :: Monad m => SigFun f g -> SigFunM m f g +sigFunM f = return . f + +{-| Lift the given signature function to a monadic term homomorphism. -} +homM :: (Difunctor g, Monad m) => SigFunM m f g -> HomM m f g +homM f = liftM simpCxt . f + +-- | Apply a monadic term homomorphism recursively to a +-- term/context. The monad is sequenced bottom-up. +appHomM :: forall f g m. (Ditraversable f, Difunctor g, Monad m) + => HomM m f g -> CxtFunM m f g +{-# NOINLINE [1] appHomM #-} +appHomM f = run + where run :: CxtFunM m f g + run (In t) = liftM appCxt . f =<< dimapM run t + run (Hole x) = return (Hole x) + run (Var p) = return (Var p) + +{-| A restricted form of |appHomM| which only works for terms. -} +appTHomM :: (Ditraversable f, ParamFunctor m, Monad m, Difunctor g) + => HomM m f g -> Term f -> m (Term g) +appTHomM f (Term t) = termM (appHomM f t) + + +-- | Apply a monadic term homomorphism recursively to a +-- term/context. The monad is sequence top-down. +appHomM' :: forall f g m. (Ditraversable g, Monad m) + => HomM m f g -> CxtFunM m f g +appHomM' f = run + where run :: CxtFunM m f g + run (In t) = liftM appCxt . dimapMCxt run =<< f t + run (Var p) = return (Var p) + run (Hole x) = return (Hole x) + +dimapMCxt :: (Ditraversable f, Monad m) + => (b -> m b') -> Cxt h f a b -> m (Cxt h f a b') +dimapMCxt f = run + where run (In t) = liftM In $ dimapM run t + run (Var a) = return $ Var a + run (Hole b) = liftM Hole (f b) + +{-| A restricted form of |appHomM'| which only works for terms. -} +appTHomM' :: (Ditraversable g, ParamFunctor m, Monad m, Difunctor g) + => HomM m f g -> Term f -> m (Term g) +appTHomM' f (Term t) = termM (appHomM' f t) + + +{-| This function constructs the unique monadic homomorphism from the + initial term algebra to the given term algebra. -} +homMD :: forall f g m. (Difunctor f, Difunctor g, Monad m) + => HomMD m f g -> CxtFunM m f g +homMD f = run + where run :: CxtFunM m f g + run (In t) = liftM appCxt (f (difmap run t)) + run (Hole x) = return (Hole x) + run (Var p) = return (Var p) + +{-| This function applies a monadic signature function to the given context. -} +appSigFunM :: forall m f g. (Ditraversable f, Monad m) + => SigFunM m f g -> CxtFunM m f g +appSigFunM f = run + where run :: CxtFunM m f g + run (In t) = liftM In . f =<< dimapM run t + run (Var x) = return $ Var x + run (Hole x) = return $ Hole x +-- implementation via term homomorphisms +-- appSigFunM f = appHomM $ hom' f + +{-| A restricted form of |appSigFunM| which only works for terms. -} +appTSigFunM :: (Ditraversable f, ParamFunctor m, Monad m, Difunctor g) + => SigFunM m f g -> Term f -> m (Term g) +appTSigFunM f (Term t) = termM (appSigFunM f t) + +-- | This function applies a monadic signature function to the given +-- context. This is a 'top-down variant of 'appSigFunM'. +appSigFunM' :: forall m f g. (Ditraversable g, Monad m) + => SigFunM m f g -> CxtFunM m f g +appSigFunM' f = run + where run :: CxtFunM m f g + run (In t) = liftM In . dimapM run =<< f t + run (Var x) = return $ Var x + run (Hole x) = return $ Hole x + +{-| A restricted form of |appSigFunM'| which only works for terms. -} +appTSigFunM' :: (Ditraversable g, ParamFunctor m, Monad m, Difunctor g) + => SigFunM m f g -> Term f -> m (Term g) +appTSigFunM' f (Term t) = termM (appSigFunM' f t) + +{-| This function applies a signature function to the given context. -} +appSigFunMD :: forall f g m. (Ditraversable f, Difunctor g, Monad m) + => SigFunMD m f g -> CxtFunM m f g +appSigFunMD f = run + where run :: CxtFunM m f g + run (In t) = liftM In (f (difmap run t)) + run (Hole x) = return (Hole x) + run (Var p) = return (Var p) + +{-| A restricted form of |appSigFunMD| which only works for terms. -} +appTSigFunMD :: (Ditraversable f, ParamFunctor m, Monad m, Difunctor g) + => SigFunMD m f g -> Term f -> m (Term g) +appTSigFunMD f (Term t) = termM (appSigFunMD f t) + +{-| Compose two monadic term homomorphisms. -} +compHomM :: (Ditraversable g, Difunctor h, Monad m) + => HomM m g h -> HomM m f g -> HomM m f h +compHomM f g = appHomM f <=< g + +{-| Compose two monadic term homomorphisms. -} +compHomM' :: (Ditraversable h, Monad m) => HomM m g h -> HomM m f g -> HomM m f h +compHomM' f g = appHomM' f <=< g + +{-{-| Compose two monadic term homomorphisms. -} +compHomM_ :: (Difunctor h, Difunctor g, Monad m) + => Hom g h -> HomM m f g -> HomM m f h +compHomM_ f g = liftM (appHom f) . g + +{-| Compose two monadic term homomorphisms. -} +compHomSigFunM :: Monad m => HomM m g h -> SigFunM m f g -> HomM m f h +compHomSigFunM f g = f <=< g-} + +{-| Compose two monadic term homomorphisms. -} +compSigFunHomM :: (Ditraversable g, Monad m) + => SigFunM m g h -> HomM m f g -> HomM m f h +compSigFunHomM f g = appSigFunM f <=< g + +{-| Compose two monadic term homomorphisms. -} +compSigFunHomM' :: (Ditraversable h, Monad m) + => SigFunM m g h -> HomM m f g -> HomM m f h +compSigFunHomM' f g = appSigFunM' f <=< g + +{-| Compose a monadic algebra with a monadic term homomorphism to get a new + monadic algebra. -} +compAlgM :: (Ditraversable g, Monad m) => AlgM m g a -> HomM m f g -> AlgM m f a +compAlgM alg talg = freeM alg return <=< talg + + +{-| Compose a monadic algebra with a term homomorphism to get a new monadic + algebra. -} +compAlgM' :: (Ditraversable g, Monad m) => AlgM m g a -> Hom f g -> AlgM m f a +compAlgM' alg talg = freeM alg return . talg + +{-| Compose a monadic algebra with a monadic signature function to get a new + monadic algebra. -} +compAlgSigFunM :: Monad m => AlgM m g a -> SigFunM m f g -> AlgM m f a +compAlgSigFunM alg talg = alg <=< talg + + +{-| Compose a monadic algebra with a signature function to get a new monadic + algebra. -} +compAlgSigFunM' :: AlgM m g a -> SigFun f g -> AlgM m f a +compAlgSigFunM' alg talg = alg . talg + +{-| This function composes two monadic signature functions. -} +compSigFunM :: Monad m => SigFunM m g h -> SigFunM m f g -> SigFunM m f h +compSigFunM f g = f <=< g + + +---------------- +-- Coalgebras -- +---------------- + +{-| This type represents a coalgebra over a difunctor @f@ and carrier @a@. The + list of @(a,b)@s represent the parameters that may occur in the constructed + value. The first component represents the seed of the parameter, + and the second component is the (polymorphic) parameter itself. If @f@ is + itself a binder, then the parameters bound by @f@ can be passed to the + covariant argument, thereby making them available to sub terms. -} +type Coalg f a = forall b. a -> [(a,b)] -> Either b (f b (a,[(a,b)])) + +{-| Construct an anamorphism from the given coalgebra. -} +ana :: Difunctor f => Coalg f a -> a -> Term f +ana f x = Term $ anaAux f x + where anaAux :: Difunctor f => Coalg f a -> a -> (forall a. Trm f a) + anaAux f x = run (x,[]) + where run (a,bs) = case f a bs of + Left p -> Var p + Right t -> In $ difmap run t + +{-| This type represents a monadic coalgebra over a difunctor @f@ and carrier + @a@. -} +type CoalgM m f a = forall b. a -> [(a,b)] -> m (Either b (f b (a,[(a,b)]))) + +{-| Construct a monadic anamorphism from the given monadic coalgebra. -} +anaM :: forall a m f. (Ditraversable f, Monad m) + => CoalgM m f a -> a -> forall a. m (Trm f a) +anaM f x = run (x,[]) + where run (a,bs) = do c <- f a bs + case c of + Left p -> return $ Var p + Right t -> liftM In $ dimapM run t + + +-------------------------------- +-- R-Algebras & Paramorphisms -- +-------------------------------- + +{-| This type represents an r-algebra over a difunctor @f@ and carrier @a@. -} +type RAlg f a = f a (Trm f a, a) -> a + +{-| Construct a paramorphism from the given r-algebra. -} +para :: forall f a. Difunctor f => RAlg f a -> Term f -> a +para f (Term t) = run t + where run :: Trm f a -> a + run (In t) = f $ difmap (\x -> (x, run x)) t + run (Var x) = x + +{-| This type represents a monadic r-algebra over a difunctor @f@ and carrier + @a@. -} +type RAlgM m f a = f a (Trm f a, a) -> m a +{-| Construct a monadic paramorphism from the given monadic r-algebra. -} +paraM :: forall m f a. (Ditraversable f, Monad m) => RAlgM m f a -> Term f -> m a +paraM f (Term t) = run t + where run :: Trm f a -> m a + run (In t) = f =<< dimapM (\x -> run x >>= \y -> return (x, y)) t + run (Var x) = return x + + +-------------------------------- +-- R-Coalgebras & Apomorphisms -- +-------------------------------- + +{-| This type represents an r-coalgebra over a difunctor @f@ and carrier @a@. -} +type RCoalg f a = forall b. a -> [(a,b)] -> Either b (f b (Either (Trm f b) (a,[(a,b)]))) + +{-| Construct an apomorphism from the given r-coalgebra. -} +apo :: Difunctor f => RCoalg f a -> a -> Term f +apo f x = Term (apoAux f x) + where apoAux :: Difunctor f => RCoalg f a -> a -> (forall a. Trm f a) + apoAux coa x = run (x,[]) + where -- run :: (a,[(a,b)]) -> Trm f b + run (a,bs) = case coa a bs of + Left x -> Var x + Right t -> In $ difmap run' t + -- run' :: Either (Trm f b) (a,[(a,b)]) -> Trm f b + run' (Left t) = t + run' (Right x) = run x + + + +{-| This type represents a monadic r-coalgebra over a functor @f@ and carrier + @a@. -} +type RCoalgM m f a = forall b. a -> [(a,b)] -> m (Either b (f b (Either (Trm f b) (a,[(a,b)])))) + +{-| Construct a monadic apomorphism from the given monadic r-coalgebra. -} +apoM :: forall f m a. (Ditraversable f, Monad m) + => RCoalgM m f a -> a -> forall a. m (Trm f a) +apoM coa x = run (x,[]) + where run (a,bs) = do + res <- coa a bs + case res of + Left x -> return $ Var x + Right t -> liftM In $ dimapM run' t + run' (Left t) = return t + run' (Right x) = run x + + +---------------------------------- +-- CV-Algebras & Histomorphisms -- +---------------------------------- + +{-| This type represents a cv-algebra over a difunctor @f@ and carrier @a@. -} +type CVAlg f a f' = f a (Trm f' a) -> a + +-- | This function applies 'projectA' at the tip of the term. +projectTip :: DistAnn f a f' => Trm f' a -> a +projectTip (In v) = snd $ projectA v +projectTip (Var p) = p + +{-| Construct a histomorphism from the given cv-algebra. -} +histo :: forall f f' a. (Difunctor f, DistAnn f a f') + => CVAlg f a f' -> Term f -> a +histo alg = projectTip . cata run + where run :: Alg f (Trm f' a) + run v = In $ injectA (alg v') v' + where v' = dimap Var id v + +{-| This type represents a monadic cv-algebra over a functor @f@ and carrier + @a@. -} +type CVAlgM m f a f' = f a (Trm f' a) -> m a + +{-| Construct a monadic histomorphism from the given monadic cv-algebra. -} +histoM :: forall f f' m a. (Ditraversable f, Monad m, DistAnn f a f') + => CVAlgM m f a f' -> Term f -> m a +histoM alg (Term t) = liftM projectTip (run t) + where run :: Trm f a -> m (Trm f' a) + run (In t) = do t' <- dimapM run t + r <- alg t' + return $ In $ injectA r t' + run (Var p) = return $ Var p + + +----------------------------------- +-- CV-Coalgebras & Futumorphisms -- +----------------------------------- + +{-| This type represents a cv-coalgebra over a difunctor @f@ and carrier @a@. + The list of @(a,b)@s represent the parameters that may occur in the + constructed value. The first component represents the seed of the parameter, + and the second component is the (polymorphic) parameter itself. If @f@ is + itself a binder, then the parameters bound by @f@ can be passed to the + covariant argument, thereby making them available to sub terms. -} +type CVCoalg f a = forall b. a -> [(a,b)] + -> Either b (f b (Context f b (a,[(a,b)]))) + +{-| Construct a futumorphism from the given cv-coalgebra. -} +futu :: Difunctor f => CVCoalg f a -> a -> Term f +futu f x = Term (futuAux f x) + where futuAux :: Difunctor f => CVCoalg f a -> a -> (forall a. Trm f a) + futuAux coa x = run (x,[]) + where run (a,bs) = case coa a bs of + Left p -> Var p + Right t -> In $ difmap run' t + run' (In t) = In $ difmap run' t + run' (Hole x) = run x + run' (Var p) = Var p + +{-| This type represents a monadic cv-coalgebra over a difunctor @f@ and carrier + @a@. -} +type CVCoalgM m f a = forall b. a -> [(a,b)] + -> m (Either b (f b (Context f b (a,[(a,b)])))) + +{-| Construct a monadic futumorphism from the given monadic cv-coalgebra. -} +futuM :: forall f a m. (Ditraversable f, Monad m) => + CVCoalgM m f a -> a -> forall a. m (Trm f a) +futuM coa x = run (x,[]) + where run (a,bs) = do c <- coa a bs + case c of + Left p -> return $ Var p + Right t -> liftM In $ dimapM run' t + run' (In t) = liftM In $ dimapM run' t + run' (Hole x) = run x + run' (Var p) = return $ Var p + +{-| This type represents a generalised cv-coalgebra over a difunctor @f@ and + carrier @a@. -} +type CVCoalg' f a = forall b. a -> [(a,b)] -> Context f b (a,[(a,b)]) + +{-| Construct a futumorphism from the given generalised cv-coalgebra. -} +futu' :: Difunctor f => CVCoalg' f a -> a -> Term f +futu' f x = Term (futuAux' f x) + where futuAux' :: Difunctor f => CVCoalg' f a -> a -> (forall a. Trm f a) + futuAux' coa x = run (x,[]) + where run (a,bs) = run' $ coa a bs + run' (In t) = In $ difmap run' t + run' (Hole x) = run x + run' (Var p) = Var p + +{-------------------------------------------- +-- functions only used for rewrite rules -- +------------------------------------------- + +appAlgHom :: forall f g d. Difunctor g => Alg g d -> Hom f g -> Term f -> d +{-# NOINLINE [1] appAlgHom #-} +appAlgHom alg hom (Term t) = run t where + run :: Trm f d -> d + run (In t) = run' $ hom t + run (Var a) = a + run' :: Context g d (Trm f d) -> d + run' (In t) = alg $ fmap run' t + run' (Var a) = a + run' (Hole x) = run x + + +-- | This function applies a signature function after a term homomorphism. +appSigFunHom :: forall f g h. (Difunctor g) + => SigFun g h -> Hom f g -> CxtFun f h +{-# NOINLINE [1] appSigFunHom #-} +appSigFunHom f g = run where + run :: CxtFun f h + run (In t) = run' $ g t + run (Var a) = Var a + run (Hole h) = Hole h + run' :: Context g a (Cxt h' f a b) -> Cxt h' h a b + run' (In t) = In $ f $ fmap run' t + run' (Var a) = Var a + run' (Hole h) = run h + +appAlgHomM :: forall m g f d. Ditraversable g + => AlgM m g d -> HomM m f g -> Term f -> m d +appAlgHomM alg hom (Term t) = run t where + run :: Trm f d -> m d + run (In t) = run' =<< hom t + run (Var a) = return a + run' :: Context g d (Trm f d) -> m d + run' (In t) = alg =<< dimapM run' t + run' (Var a) = return a + run' (Hole x) = run x + +appHomHomM :: forall m f g h. (Ditraversable g, Difunctor h) + => HomM m g h -> HomM m f g -> CxtFunM m f h +appHomHomM f g = run where +-- run :: CxtFunM m f h + run (In t) = run' =<< g t + run (Var a) = return $ Var a + run (Hole h) = return $ Hole h +-- run' :: Context g Any (Cxt h' f Any b) -> m (Cxt h' h Any b) + run' (In t) = liftM appCxt $ f =<< dimapM run' t + run' (Var a) = return $ Var a + run' (Hole h) = run h + +appSigFunHomM :: forall m f g h. Ditraversable g + => SigFunM m g h -> HomM m f g -> CxtFunM m f h +appSigFunHomM f g = run where +-- run :: CxtFunM m f h + run (In t) = run' =<< g t + run (Var a) = return $ Var a + run (Hole h) = return $ Hole h +-- run' :: Context g Any (Cxt h' f Any b) -> m (Cxt h' h Any b) + run' (In t) = liftM In $ f =<< dimapM run' t + run' (Var a) = return $ Var a + run' (Hole h) = run h + + +------------------- +-- rewrite rules -- +------------------- + +#ifndef NO_RULES +{-# RULES + "cata/appHom" forall (a :: Alg g d) (h :: Hom f g) x. + cata a (appHom h x) = cata (compAlg a h) x; + + "cata/appHom'" forall (a :: Alg g d) (h :: Hom f g) x. + cata a (appHom' h x) = appAlgHom a h x; + + "cata/appSigFun" forall (a :: Alg g d) (h :: SigFun f g) x. + cata a (appSigFun h x) = cata (compAlgSigFun a h) x; + + "cata/appSigFun'" forall (a :: Alg g d) (h :: SigFun f g) x. + cata a (appSigFun' h x) = appAlgHom a (hom h) x; + + "cata/appSigFunHom" forall (f :: Alg f3 d) (g :: SigFun f2 f3) + (h :: Hom f1 f2) x. + cata f (appSigFunHom g h x) = appAlgHom (compAlgSigFun f g) h x; + + "appAlgHom/appHom" forall (a :: Alg h d) (f :: Hom f g) (h :: Hom g h) x. + appAlgHom a h (appHom f x) = cata (compAlg a (compHom h f)) x; + + "appAlgHom/appHom'" forall (a :: Alg h d) (f :: Hom f g) (h :: Hom g h) x. + appAlgHom a h (appHom' f x) = appAlgHom a (compHom h f) x; + + "appAlgHom/appSigFun" forall (a :: Alg h d) (f :: SigFun f g) (h :: Hom g h) x. + appAlgHom a h (appSigFun f x) = cata (compAlg a (compHomSigFun h f)) x; + + "appAlgHom/appSigFun'" forall (a :: Alg h d) (f :: SigFun f g) (h :: Hom g h) x. + appAlgHom a h (appSigFun' f x) = appAlgHom a (compHomSigFun h f) x; + + "appAlgHom/appSigFunHom" forall (a :: Alg i d) (f :: Hom f g) (g :: SigFun g h) + (h :: Hom h i) x. + appAlgHom a h (appSigFunHom g f x) + = appAlgHom a (compHom (compHomSigFun h g) f) x; + + "appHom/appHom" forall (a :: Hom g h) (h :: Hom f g) x. + appHom a (appHom h x) = appHom (compHom a h) x; + + "appHom'/appHom'" forall (a :: Hom g h) (h :: Hom f g) x. + appHom' a (appHom' h x) = appHom' (compHom a h) x; + + "appHom'/appHom" forall (a :: Hom g h) (h :: Hom f g) x. + appHom' a (appHom h x) = appHom (compHom a h) x; + + "appHom/appHom'" forall (a :: Hom g h) (h :: Hom f g) x. + appHom a (appHom' h x) = appHom' (compHom a h) x; + + "appSigFun/appSigFun" forall (f :: SigFun g h) (g :: SigFun f g) x. + appSigFun f (appSigFun g x) = appSigFun (compSigFun f g) x; + + "appSigFun'/appSigFun'" forall (f :: SigFun g h) (g :: SigFun f g) x. + appSigFun' f (appSigFun' g x) = appSigFun' (compSigFun f g) x; + + "appSigFun/appSigFun'" forall (f :: SigFun g h) (g :: SigFun f g) x. + appSigFun f (appSigFun' g x) = appSigFunHom f (hom g) x; + + "appSigFun'/appSigFun" forall (f :: SigFun g h) (g :: SigFun f g) x. + appSigFun' f (appSigFun g x) = appSigFun (compSigFun f g) x; + + "appHom/appSigFun" forall (f :: Hom g h) (g :: SigFun f g) x. + appHom f (appSigFun g x) = appHom (compHomSigFun f g) x; + + "appHom/appSigFun'" forall (f :: Hom g h) (g :: SigFun f g) x. + appHom f (appSigFun' g x) = appHom' (compHomSigFun f g) x; + + "appHom'/appSigFun'" forall (f :: Hom g h) (g :: SigFun f g) x. + appHom' f (appSigFun' g x) = appHom' (compHomSigFun f g) x; + + "appHom'/appSigFun" forall (f :: Hom g h) (g :: SigFun f g) x. + appHom' f (appSigFun g x) = appHom (compHomSigFun f g) x; + + "appSigFun/appHom" forall (f :: SigFun g h) (g :: Hom f g) x. + appSigFun f (appHom g x) = appSigFunHom f g x; + + "appSigFun'/appHom'" forall (f :: SigFun g h) (g :: Hom f g) x. + appSigFun' f (appHom' g x) = appHom' (compSigFunHom f g) x; + + "appSigFun/appHom'" forall (f :: SigFun g h) (g :: Hom f g) x. + appSigFun f (appHom' g x) = appSigFunHom f g x; + + "appSigFun'/appHom" forall (f :: SigFun g h) (g :: Hom f g) x. + appSigFun' f (appHom g x) = appHom (compSigFunHom f g) x; + + "appSigFunHom/appSigFun" forall (f :: SigFun f3 f4) (g :: Hom f2 f3) + (h :: SigFun f1 f2) x. + appSigFunHom f g (appSigFun h x) + = appSigFunHom f (compHomSigFun g h) x; + + "appSigFunHom/appSigFun'" forall (f :: SigFun f3 f4) (g :: Hom f2 f3) + (h :: SigFun f1 f2) x. + appSigFunHom f g (appSigFun' h x) + = appSigFunHom f (compHomSigFun g h) x; + + "appSigFunHom/appHom" forall (f :: SigFun f3 f4) (g :: Hom f2 f3) + (h :: Hom f1 f2) x. + appSigFunHom f g (appHom h x) + = appSigFunHom f (compHom g h) x; + + "appSigFunHom/appHom'" forall (f :: SigFun f3 f4) (g :: Hom f2 f3) + (h :: Hom f1 f2) x. + appSigFunHom f g (appHom' h x) + = appSigFunHom f (compHom g h) x; + + "appSigFun/appSigFunHom" forall (f :: SigFun f3 f4) (g :: SigFun f2 f3) + (h :: Hom f1 f2) x. + appSigFun f (appSigFunHom g h x) = appSigFunHom (compSigFun f g) h x; + + "appSigFun'/appSigFunHom" forall (f :: SigFun f3 f4) (g :: SigFun f2 f3) + (h :: Hom f1 f2) x. + appSigFun' f (appSigFunHom g h x) = appSigFunHom (compSigFun f g) h x; + + "appHom/appSigFunHom" forall (f :: Hom f3 f4) (g :: SigFun f2 f3) + (h :: Hom f1 f2) x. + appHom f (appSigFunHom g h x) = appHom' (compHom (compHomSigFun f g) h) x; + + "appHom'/appSigFunHom" forall (f :: Hom f3 f4) (g :: SigFun f2 f3) + (h :: Hom f1 f2) x. + appHom' f (appSigFunHom g h x) = appHom' (compHom (compHomSigFun f g) h) x; + + "appSigFunHom/appSigFunHom" forall (f1 :: SigFun f4 f5) (f2 :: Hom f3 f4) + (f3 :: SigFun f2 f3) (f4 :: Hom f1 f2) x. + appSigFunHom f1 f2 (appSigFunHom f3 f4 x) + = appSigFunHom f1 (compHom (compHomSigFun f2 f3) f4) x; #-} + +{-# RULES + "cataM/appHomM" forall (a :: AlgM Maybe g d) (h :: HomM Maybe f g) x. + appHomM h x >>= cataM a = appAlgHomM a h x; + + "cataM/appHomM'" forall (a :: AlgM Maybe g d) (h :: HomM Maybe f g) x. + appHomM' h x >>= cataM a = appAlgHomM a h x; + + "cataM/appSigFunM" forall (a :: AlgM Maybe g d) (h :: SigFunM Maybe f g) x. + appSigFunM h x >>= cataM a = appAlgHomM a (homM h) x; + + "cataM/appSigFunM'" forall (a :: AlgM Maybe g d) (h :: SigFunM Maybe f g) x. + appSigFunM' h x >>= cataM a = appAlgHomM a (homM h) x; + + "cataM/appHom" forall (a :: AlgM m g d) (h :: Hom f g) x. + cataM a (appHom h x) = appAlgHomM a (sigFunM h) x; + + "cataM/appHom'" forall (a :: AlgM m g d) (h :: Hom f g) x. + cataM a (appHom' h x) = appAlgHomM a (sigFunM h) x; + + "cataM/appSigFun" forall (a :: AlgM m g d) (h :: SigFun f g) x. + cataM a (appSigFun h x) = appAlgHomM a (sigFunM $ hom h) x; + + "cataM/appSigFun'" forall (a :: AlgM m g d) (h :: SigFun f g) x. + cataM a (appSigFun' h x) = appAlgHomM a (sigFunM $ hom h) x; + + "cataM/appSigFun" forall (a :: AlgM m g d) (h :: SigFun f g) x. + cataM a (appSigFun h x) = appAlgHomM a (sigFunM $ hom h) x; + + "cataM/appSigFunHom" forall (a :: AlgM m h d) (g :: SigFun g h) (f :: Hom f g) x. + cataM a (appSigFunHom g f x) = appAlgHomM a (sigFunM $ compSigFunHom g f) x; + + "appHomM/appHomM" forall (a :: HomM Maybe g h) (h :: HomM Maybe f g) x. + appHomM h x >>= appHomM a = appHomM (compHomM a h) x; + + "appHomM/appSigFunM" forall (a :: HomM Maybe g h) (h :: SigFunM Maybe f g) x. + appSigFunM h x >>= appHomM a = appHomM (compHomSigFunM a h) x; + + "appHomM/appHomM'" forall (a :: HomM Maybe g h) (h :: HomM Maybe f g) x. + appHomM' h x >>= appHomM a = appHomHomM a h x; + + "appHomM/appSigFunM'" forall (a :: HomM Maybe g h) (h :: SigFunM Maybe f g) x. + appSigFunM' h x >>= appHomM a = appHomHomM a (homM h) x; + + "appHomM'/appHomM" forall (a :: HomM Maybe g h) (h :: HomM Maybe f g) x. + appHomM h x >>= appHomM' a = appHomM' (compHomM' a h) x; + + "appHomM'/appSigFunM" forall (a :: HomM Maybe g h) (h :: SigFunM Maybe f g) x. + appSigFunM h x >>= appHomM' a = appHomM' (compHomSigFunM a h) x; + + "appHomM'/appHomM'" forall (a :: HomM Maybe g h) (h :: HomM Maybe f g) x. + appHomM' h x >>= appHomM' a = appHomM' (compHomM' a h) x; + + "appHomM'/appSigFunM'" forall (a :: HomM Maybe g h) (h :: SigFunM Maybe f g) x. + appSigFunM' h x >>= appHomM' a = appHomM' (compHomSigFunM a h) x; + + "appHomM/appHom" forall (a :: HomM m g h) (h :: Hom f g) x. + appHomM a (appHom h x) = appHomHomM a (sigFunM h) x; + + "appHomM/appSigFun" forall (a :: HomM m g h) (h :: SigFun f g) x. + appHomM a (appSigFun h x) = appHomHomM a (sigFunM $ hom h) x; + + "appHomM'/appHom" forall (a :: HomM m g h) (h :: Hom f g) x. + appHomM' a (appHom h x) = appHomM' (compHomM' a (sigFunM h)) x; + + "appHomM'/appSigFun" forall (a :: HomM m g h) (h :: SigFun f g) x. + appHomM' a (appSigFun h x) = appHomM' (compHomSigFunM a (sigFunM h)) x; + + "appHomM/appHom'" forall (a :: HomM m g h) (h :: Hom f g) x. + appHomM a (appHom' h x) = appHomHomM a (sigFunM h) x; + + "appHomM/appSigFun'" forall (a :: HomM m g h) (h :: SigFun f g) x. + appHomM a (appSigFun' h x) = appHomHomM a (sigFunM $ hom h) x; + + "appHomM'/appHom'" forall (a :: HomM m g h) (h :: Hom f g) x. + appHomM' a (appHom' h x) = appHomM' (compHomM' a (sigFunM h)) x; + + "appHomM'/appSigFun'" forall (a :: HomM m g h) (h :: SigFun f g) x. + appHomM' a (appSigFun' h x) = appHomM' (compHomSigFunM a (sigFunM h)) x; + + "appSigFunM/appHomM" forall (a :: SigFunM Maybe g h) (h :: HomM Maybe f g) x. + appHomM h x >>= appSigFunM a = appSigFunHomM a h x; + + "appSigFunHomM/appSigFunM" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x. + appSigFunM h x >>= appSigFunM a = appSigFunM (compSigFunM a h) x; + + "appSigFunM/appHomM'" forall (a :: SigFunM Maybe g h) (h :: HomM Maybe f g) x. + appHomM' h x >>= appSigFunM a = appSigFunHomM a h x; + + "appSigFunM/appSigFunM'" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x. + appSigFunM' h x >>= appSigFunM a = appSigFunHomM a (homM h) x; + + "appSigFunM'/appHomM" forall (a :: SigFunM Maybe g h) (h :: HomM Maybe f g) x. + appHomM h x >>= appSigFunM' a = appHomM' (compSigFunHomM' a h) x; + + "appSigFunM'/appSigFunM" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x. + appSigFunM h x >>= appSigFunM' a = appSigFunM' (compSigFunM a h) x; + + "appSigFunM'/appHomM'" forall (a :: SigFunM Maybe g h) (h :: HomM Maybe f g) x. + appHomM' h x >>= appSigFunM' a = appHomM' (compSigFunHomM' a h) x; + + "appSigFunM'/appSigFunM'" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x. + appSigFunM' h x >>= appSigFunM' a = appSigFunM' (compSigFunM a h) x; + + "appSigFunM/appHom" forall (a :: SigFunM m g h) (h :: Hom f g) x. + appSigFunM a (appHom h x) = appSigFunHomM a (sigFunM h) x; + + "appSigFunM/appSigFun" forall (a :: SigFunM m g h) (h :: SigFun f g) x. + appSigFunM a (appSigFun h x) = appSigFunHomM a (sigFunM $ hom h) x; + + "appSigFunM'/appHom" forall (a :: SigFunM m g h) (h :: Hom f g) x. + appSigFunM' a (appHom h x) = appHomM' (compSigFunHomM' a (sigFunM h)) x; + + "appSigFunM'/appSigFun" forall (a :: SigFunM m g h) (h :: SigFun f g) x. + appSigFunM' a (appSigFun h x) = appSigFunM' (compSigFunM a (sigFunM h)) x; + + "appSigFunM/appHom'" forall (a :: SigFunM m g h) (h :: Hom f g) x. + appSigFunM a (appHom' h x) = appSigFunHomM a (sigFunM h) x; + + "appSigFunM/appSigFun'" forall (a :: SigFunM m g h) (h :: SigFun f g) x. + appSigFunM a (appSigFun' h x) = appSigFunHomM a (sigFunM $ hom h) x; + + "appSigFunM'/appHom'" forall (a :: SigFunM m g h) (h :: Hom f g) x. + appSigFunM' a (appHom' h x) = appHomM' (compSigFunHomM' a (sigFunM h)) x; + + "appSigFunM'/appSigFun'" forall (a :: SigFunM m g h) (h :: SigFun f g) x. + appSigFunM' a (appSigFun' h x) = appSigFunM' (compSigFunM a (sigFunM h)) x; + + + "appHom/appHomM" forall (a :: Hom g h) (h :: HomM m f g) x. + appHomM h x >>= (return . appHom a) = appHomM (compHomM_ a h) x; #-} +#endif +-} diff --git a/compdata-param-master/src/Data/Comp/Param/Annotation.hs b/compdata-param-master/src/Data/Comp/Param/Annotation.hs new file mode 100755 index 0000000..7bd4bec --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Annotation.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances, + UndecidableInstances, Rank2Types, GADTs, ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Annotation +-- Copyright : (c) 2010-2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines annotations on signatures. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Annotation + ( + (:&:) (..), + (:*:) (..), + DistAnn (..), + RemA (..), + liftA, + liftA', + stripA, + propAnn, + propAnnM, + ann, + project' + ) where + +import Data.Comp.Param.Difunctor +import Data.Comp.Param.Term +import Data.Comp.Param.Sum +import Data.Comp.Param.Ops +import Data.Comp.Param.Algebra + +import Control.Monad + +{-| Transform a function with a domain constructed from a functor to a function + with a domain constructed with the same functor, but with an additional + annotation. -} +liftA :: (RemA s s') => (s' a b -> t) -> s a b -> t +liftA f v = f (remA v) + +{-| Transform a function with a domain constructed from a functor to a function + with a domain constructed with the same functor, but with an additional + annotation. -} +liftA' :: (DistAnn s' p s, Difunctor s') + => (s' a b -> Cxt h s' c d) -> s a b -> Cxt h s c d +liftA' f v = let (v',p) = projectA v + in ann p (f v') + +{-| Strip the annotations from a term over a functor with annotations. -} +stripA :: (RemA g f, Difunctor g) => CxtFun g f +stripA = appSigFun remA + +{-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism + over the same signatures, but extended with annotations. -} +propAnn :: (DistAnn f p f', DistAnn g p g', Difunctor g) + => Hom f g -> Hom f' g' +propAnn hom f' = ann p (hom f) + where (f,p) = projectA f' + +{-| Lift a monadic term homomorphism over signatures @f@ and @g@ to a monadic + term homomorphism over the same signatures, but extended with annotations. -} +propAnnM :: (DistAnn f p f', DistAnn g p g', Difunctor g, Monad m) + => HomM m f g -> HomM m f' g' +propAnnM hom f' = liftM (ann p) (hom f) + where (f,p) = projectA f' + +{-| Annotate each node of a term with a constant value. -} +ann :: (DistAnn f p g, Difunctor f) => p -> CxtFun f g +ann c = appSigFun (injectA c) + +{-| This function is similar to 'project' but applies to signatures +with an annotation which is then ignored. -} +project' :: (RemA f f', s :<: f') => Cxt h f a b -> Maybe (s a (Cxt h f a b)) +project' (In x) = proj $ remA x +project' _ = Nothing \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Derive.hs b/compdata-param-master/src/Data/Comp/Param/Derive.hs new file mode 100755 index 0000000..1d5a934 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Derive.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Derive +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module contains functionality for automatically deriving boilerplate +-- code using Template Haskell. Examples include instances of 'Difunctor', +-- 'Difoldable', and 'Ditraversable'. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Derive + ( + derive, + -- |Derive boilerplate instances for parametric signatures, i.e. + -- signatures for parametric compositional data types. + + -- ** EqD + module Data.Comp.Param.Derive.Equality, + -- ** OrdD + module Data.Comp.Param.Derive.Ordering, + -- ** ShowD + module Data.Comp.Param.Derive.Show, + -- ** Difunctor + module Data.Comp.Param.Derive.Difunctor, + -- ** Ditraversable + module Data.Comp.Param.Derive.Ditraversable, + -- ** Smart Constructors + module Data.Comp.Param.Derive.SmartConstructors, + -- ** Smart Constructors w/ Annotations + module Data.Comp.Param.Derive.SmartAConstructors, + -- ** Lifting to Sums + liftSum + ) where + +import Data.Comp.Derive.Utils (derive, liftSumGen) +import Data.Comp.Param.Derive.Equality +import Data.Comp.Param.Derive.Ordering +import Data.Comp.Param.Derive.Show +import Data.Comp.Param.Derive.Difunctor +import Data.Comp.Param.Derive.Ditraversable +import Data.Comp.Param.Derive.SmartConstructors +import Data.Comp.Param.Derive.SmartAConstructors +import Data.Comp.Param.Ops ((:+:), caseD) + +import Language.Haskell.TH + +{-| Given the name of a type class, where the first parameter is a difunctor, + lift it to sums of difunctors. Example: @class ShowD f where ...@ is lifted + as @instance (ShowD f, ShowD g) => ShowD (f :+: g) where ... @. -} +liftSum :: Name -> Q [Dec] +liftSum = liftSumGen 'caseD ''(:+:) \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Derive/Difunctor.hs b/compdata-param-master/src/Data/Comp/Param/Derive/Difunctor.hs new file mode 100755 index 0000000..de00784 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Derive/Difunctor.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Derive.Functor +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Automatically derive instances of @Difunctor@. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Derive.Difunctor + ( + Difunctor, + makeDifunctor + ) where + +import Data.Comp.Derive.Utils +import Data.Comp.Param.Difunctor +import Language.Haskell.TH + +{-| Derive an instance of 'Difunctor' for a type constructor of any parametric + kind taking at least two arguments. -} +makeDifunctor :: Name -> Q [Dec] +makeDifunctor fname = do + -- Comments below apply to the example where name = T, args = [a,b,c], and + -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type + -- declaration: T a b c = X c | Y a c | Z (b -> c) + TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname + -- coArg = c (covariant difunctor argument) + let coArg :: Name = tyVarBndrName $ last args + -- conArg = b (contravariant difunctor argument) + let conArg :: Name = tyVarBndrName $ last $ init args + -- argNames = [a] + let argNames = map (VarT . tyVarBndrName) (init $ init args) + -- compType = T a + let complType = foldl AppT (ConT name) argNames + -- classType = Difunctor (T a) + let classType = AppT (ConT ''Difunctor) complType + -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])] + constrs' :: [(Name,[Type])] <- mapM normalConExp constrs + dimapDecl <- funD 'dimap (map (dimapClause conArg coArg) constrs') + return [InstanceD [] classType [dimapDecl]] + where dimapClause :: Name -> Name -> (Name,[Type]) -> ClauseQ + dimapClause conArg coArg (constr, args) = do + fn <- newName "_f" + gn <- newName "_g" + varNs <- newNames (length args) "x" + let f = varE fn + let g = varE gn + let fp = VarP fn + let gp = VarP gn + -- Pattern for the constructor + let pat = ConP constr $ map VarP varNs + body <- dimapArgs conArg coArg f g (zip varNs args) (conE constr) + return $ Clause [fp, gp, pat] (NormalB body) [] + dimapArgs :: Name -> Name -> ExpQ -> ExpQ + -> [(Name, Type)] -> ExpQ -> ExpQ + dimapArgs _ _ _ _ [] acc = + acc + dimapArgs conArg coArg f g ((x,tp):tps) acc = + dimapArgs conArg coArg f g tps + (acc `appE` (dimapArg conArg coArg tp f g `appE` varE x)) + -- Given the name of the difunctor variables, a type, and the two + -- arguments to dimap, return the expression that should be applied + -- to the parameter of the given type. + -- Example: dimapArg a b (a -> b) f g yields the expression + -- [|\x -> g . x . f|] + dimapArg :: Name -> Name -> Type -> ExpQ -> ExpQ -> ExpQ + dimapArg conArg coArg tp f g + | not (containsType tp (VarT conArg)) && + not (containsType tp (VarT coArg)) = [| id |] + | otherwise = + case tp of + VarT a | a == conArg -> f + | a == coArg -> g + AppT (AppT ArrowT tp1) tp2 -> do + xn <- newName "x" + let ftp1 = dimapArg conArg coArg tp1 f g + let ftp2 = dimapArg conArg coArg tp2 f g + lamE [varP xn] + (infixE (Just ftp2) + [|(.)|] + (Just $ infixE (Just $ varE xn) + [|(.)|] + (Just ftp1))) + SigT tp' _ -> + dimapArg conArg coArg tp' f g + _ -> + if containsType tp (VarT conArg) then + [| dimap $f $g |] + else + [| fmap $g |] \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Derive/Ditraversable.hs b/compdata-param-master/src/Data/Comp/Param/Derive/Ditraversable.hs new file mode 100755 index 0000000..10bfa22 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Derive/Ditraversable.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Derive.Ditraversable +-- Copyright : (c) 2010-2011 Patrick Bahr +-- License : BSD3 +-- Maintainer : Patrick Bahr +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Automatically derive instances of @Ditraversable@. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Derive.Ditraversable + ( + Ditraversable, + makeDitraversable + ) where + +import Data.Comp.Derive.Utils +import Data.Comp.Param.Ditraversable +import Data.Traversable (mapM) +import Language.Haskell.TH +import Data.Maybe +import Control.Monad hiding (mapM) +import Prelude hiding (mapM) + +iter 0 _ e = e +iter n f e = iter (n-1) f (f `appE` e) + +iter' n f e = run n f e + where run 0 _ e = e + run m f e = let f' = iter (m-1) [|fmap|] f + in run (m-1) f (f' `appE` e) + +{-| Derive an instance of 'Traversable' for a type constructor of any + first-order kind taking at least one argument. -} +makeDitraversable :: Name -> Q [Dec] +makeDitraversable fname = do + TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname + let fArg = VarT . tyVarBndrName $ last args + aArg = VarT . tyVarBndrName $ last (init args) + funTy = foldl AppT ArrowT [aArg,fArg] + argNames = map (VarT . tyVarBndrName) (init $ init args) + complType = foldl AppT (ConT name) argNames + classType = foldl1 AppT [ConT ''Ditraversable, complType] + normConstrs <- mapM normalConExp constrs + constrs' <- mapM (mkPatAndVars . isFarg fArg funTy) normConstrs + mapMDecl <- funD 'dimapM (map mapMClause constrs') + sequenceDecl <- funD 'disequence (map sequenceClause constrs') + return [InstanceD [] classType [mapMDecl,sequenceDecl]] + where isFarg fArg funTy (constr, args) = + (constr, map (\t -> (t `containsType'` fArg, t `containsType'` funTy)) args) + filterVar _ _ nonFarg ([],[]) x = nonFarg x + filterVar farg _ _ ([depth],[]) x = farg depth x + filterVar _ aarg _ ([_],[depth]) x = aarg depth x + filterVar _ _ _ _ _ = error "functor variable occurring twice in argument type" + filterVars args varNs farg aarg nonFarg = zipWith (filterVar farg aarg nonFarg) args varNs + mkCPat constr varNs = ConP constr $ map mkPat varNs + mkPat = VarP + mkPatAndVars (constr, args) = + do varNs <- newNames (length args) "x" + return (conE constr, mkCPat constr varNs, + any (not . null . fst) args || any (not . null . snd) args, map varE varNs, + catMaybes $ filterVars args varNs (\x y -> Just (False,x,y)) (\x y -> Just (True, x, y)) (const Nothing)) + + -- Note: the monadic versions are not defined + -- applicatively, as this results in a considerable + -- performance penalty (by factor 2)! + mapMClause (con, pat,hasFargs,allVars, fvars) = + do fn <- newName "f" + let f = varE fn + fp = if hasFargs then VarP fn else WildP + conAp = foldl appE con allVars + addDi False x = x + addDi True _ = [|dimapM $(f)|] + conBind (fun,d,x) y = [| $(iter d [|mapM|] (addDi fun f)) $(varE x) >>= $(lamE [varP x] y)|] + body <- foldr conBind [|return $conAp|] fvars + return $ Clause [fp, pat] (NormalB body) [] + sequenceClause (con, pat,_hasFargs,allVars, fvars) = + do let conAp = foldl appE con allVars + varE' False _ x = varE x + varE' True d x = appE (iter d [|fmap|] [|disequence|]) (varE x) + conBind (fun,d, x) y = [| $(iter' d [|sequence|] (varE' fun d x)) >>= $(lamE [varP x] y)|] + body <- foldr conBind [|return $conAp|] fvars + return $ Clause [pat] (NormalB body) [] diff --git a/compdata-param-master/src/Data/Comp/Param/Derive/Equality.hs b/compdata-param-master/src/Data/Comp/Param/Derive/Equality.hs new file mode 100755 index 0000000..96dc9d1 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Derive/Equality.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances, + ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Derive.Equality +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Automatically derive instances of @EqD@. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Derive.Equality + ( + EqD(..), + makeEqD + ) where + +import Data.Comp.Derive.Utils +import Data.Comp.Param.FreshM hiding (Name) +import Data.Comp.Param.Equality +import Control.Monad +import Language.Haskell.TH hiding (Cxt, match) + +{-| Derive an instance of 'EqD' for a type constructor of any parametric + kind taking at least two arguments. -} +makeEqD :: Name -> Q [Dec] +makeEqD fname = do + -- Comments below apply to the example where name = T, args = [a,b,c], and + -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type + -- declaration: T a b c = X c | Y a c | Z (b -> c) + TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname + -- coArg = c (covariant difunctor argument) + let coArg :: Name = tyVarBndrName $ last args + -- conArg = b (contravariant difunctor argument) + let conArg :: Name = tyVarBndrName $ last $ init args + -- argNames = [a] + let argNames = map (VarT . tyVarBndrName) (init $ init args) + -- compType = T a + let complType = foldl AppT (ConT name) argNames + -- classType = Difunctor (T a) + let classType = AppT (ConT ''EqD) complType + -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])] + constrs' :: [(Name,[Type])] <- mapM normalConExp constrs + let defC = if length constrs < 2 then + [] + else + [clause [wildP,wildP] (normalB [|return False|]) []] + eqDDecl <- funD 'eqD (map (eqDClause conArg coArg) constrs' ++ defC) + let context = map (\arg -> ClassP ''Eq [arg]) argNames + return [InstanceD context classType [eqDDecl]] + where eqDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ + eqDClause conArg coArg (constr, args) = do + varXs <- newNames (length args) "x" + varYs <- newNames (length args) "y" + -- Patterns for the constructors + let patx = ConP constr $ map VarP varXs + let paty = ConP constr $ map VarP varYs + body <- eqDBody conArg coArg (zip3 varXs varYs args) + return $ Clause [patx,paty] (NormalB body) [] + eqDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ + eqDBody conArg coArg x = + [|liftM and (sequence $(listE $ map (eqDB conArg coArg) x))|] + eqDB :: Name -> Name -> (Name, Name, Type) -> ExpQ + eqDB conArg coArg (x, y, tp) + | not (containsType tp (VarT conArg)) && + not (containsType tp (VarT coArg)) = + [| return $ $(varE x) == $(varE y) |] + | otherwise = + case tp of + VarT a + | a == coArg -> [| peq $(varE x) $(varE y) |] + AppT (AppT ArrowT (VarT a)) _ + | a == conArg -> + [| withName (\v -> peq ($(varE x) v) ($(varE y) v)) |] + SigT tp' _ -> + eqDB conArg coArg (x, y, tp') + _ -> + if containsType tp (VarT conArg) then + [| eqD $(varE x) $(varE y) |] + else + [| peq $(varE x) $(varE y) |] \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Derive/Injections.hs b/compdata-param-master/src/Data/Comp/Param/Derive/Injections.hs new file mode 100755 index 0000000..b78b823 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Derive/Injections.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Derive.Injections +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Derive functions for signature injections. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Derive.Injections + ( + injn, + injectn, + deepInjectn + ) where + +import Language.Haskell.TH hiding (Cxt) +import Data.Comp.Param.Difunctor +import Data.Comp.Param.Term +import Data.Comp.Param.Algebra (CxtFun, appSigFun) +import Data.Comp.Param.Ops ((:+:)(..), (:<:)(..)) + +injn :: Int -> Q [Dec] +injn n = do + let i = mkName $ "inj" ++ show n + let fvars = map (\n -> mkName $ 'f' : show n) [1..n] + let gvar = mkName "g" + let avar = mkName "a" + let bvar = mkName "b" + let xvar = mkName "x" + let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]] + sequence $ sigD i (genSig fvars gvar avar bvar) : d + where genSig fvars gvar avar bvar = do + let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars + let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a) + (map varT fvars) + let tp' = arrowT `appT` (tp `appT` varT avar `appT` varT bvar) + `appT` (varT gvar `appT` varT avar `appT` + varT bvar) + forallT (map PlainTV $ gvar : avar : bvar : fvars) + (sequence cxt) tp' + genDecl x n = [| case $(varE x) of + Inl x -> $(varE $ mkName "inj") x + Inr x -> $(varE $ mkName $ "inj" ++ + if n > 2 then show (n - 1) else "") x |] +injectn :: Int -> Q [Dec] +injectn n = do + let i = mkName ("inject" ++ show n) + let fvars = map (\n -> mkName $ 'f' : show n) [1..n] + let gvar = mkName "g" + let avar = mkName "a" + let bvar = mkName "b" + let d = [funD i [clause [] (normalB $ genDecl n) []]] + sequence $ sigD i (genSig fvars gvar avar bvar) : d + where genSig fvars gvar avar bvar = do + let hvar = mkName "h" + let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars + let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a) + (map varT fvars) + let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar + `appT` varT avar `appT` varT bvar + let tp'' = arrowT `appT` (tp `appT` varT avar `appT` tp') `appT` tp' + forallT (map PlainTV $ hvar : gvar : avar : bvar : fvars) + (sequence cxt) tp'' + genDecl n = [| In . $(varE $ mkName $ "inj" ++ show n) |] + +deepInjectn :: Int -> Q [Dec] +deepInjectn n = do + let i = mkName ("deepInject" ++ show n) + let fvars = map (\n -> mkName $ 'f' : show n) [1..n] + let gvar = mkName "g" + let d = [funD i [clause [] (normalB $ genDecl n) []]] + sequence $ sigD i (genSig fvars gvar) : d + where genSig fvars gvar = do + let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars + let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a) + (map varT fvars) + let cxt' = classP ''Difunctor [tp] + let tp' = conT ''CxtFun `appT` tp `appT` varT gvar + forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp' + genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |] \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Derive/LiftSum.hs b/compdata-param-master/src/Data/Comp/Param/Derive/LiftSum.hs new file mode 100755 index 0000000..987589e --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Derive/LiftSum.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Derive.LiftSum +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Lift a class declaration for difunctors to sums of difunctors. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Derive.LiftSum + ( + liftSum, + caseD + ) where + +import Language.Haskell.TH hiding (Cxt) +import Data.Comp.Derive.Utils +import Data.Comp.Param.Sum +import Data.Comp.Param.Ops ((:+:)(..)) + +{-| Given the name of a type class, where the first parameter is a difunctor, + lift it to sums of difunctors. Example: @class ShowD f where ...@ is lifted + as @instance (ShowD f, ShowD g) => ShowD (f :+: g) where ... @. -} +liftSum :: Name -> Q [Dec] +liftSum = liftSumGen 'caseD ''(:+:) + +{-| Utility function to case on a difunctor sum, without exposing the internal + representation of sums. -} +caseD :: (f a b -> c) -> (g a b -> c) -> (f :+: g) a b -> c +caseD f g x = case x of + Inl x -> f x + Inr x -> g x \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Derive/Ordering.hs b/compdata-param-master/src/Data/Comp/Param/Derive/Ordering.hs new file mode 100755 index 0000000..b4d16ac --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Derive/Ordering.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances, + ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Derive.Ordering +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Automatically derive instances of @OrdD@. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Derive.Ordering + ( + OrdD(..), + makeOrdD + ) where + +import Data.Comp.Param.FreshM hiding (Name) +import Data.Comp.Param.Ordering +import Data.Comp.Derive.Utils +import Language.Haskell.TH hiding (Cxt) +import Control.Monad (liftM) + +{-| Derive an instance of 'OrdD' for a type constructor of any parametric + kind taking at least two arguments. -} +makeOrdD :: Name -> Q [Dec] +makeOrdD fname = do + -- Comments below apply to the example where name = T, args = [a,b,c], and + -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type + -- declaration: T a b c = X c | Y a c | Z (b -> c) + TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname + -- coArg = c (covariant difunctor argument) + let coArg :: Name = tyVarBndrName $ last args + -- conArg = b (contravariant difunctor argument) + let conArg :: Name = tyVarBndrName $ last $ init args + -- argNames = [a] + let argNames = map (VarT . tyVarBndrName) (init $ init args) + -- compType = T a + let complType = foldl AppT (ConT name) argNames + -- classType = Difunctor (T a) + let classType = AppT (ConT ''OrdD) complType + -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])] + constrs' :: [(Name,[Type])] <- mapM normalConExp constrs + compareDDecl <- funD 'compareD (compareDClauses conArg coArg constrs') + let context = map (\arg -> ClassP ''Ord [arg]) argNames + return [InstanceD context classType [compareDDecl]] + where compareDClauses :: Name -> Name -> [(Name,[Type])] -> [ClauseQ] + compareDClauses _ _ [] = [] + compareDClauses conArg coArg constrs = + let constrs' = constrs `zip` [1..] + constPairs = [(x,y)| x<-constrs', y <- constrs'] + in map (genClause conArg coArg) constPairs + genClause conArg coArg ((c,n),(d,m)) + | n == m = genEqClause conArg coArg c + | n < m = genLtClause c d + | otherwise = genGtClause c d + genEqClause :: Name -> Name -> (Name,[Type]) -> ClauseQ + genEqClause conArg coArg (constr, args) = do + varXs <- newNames (length args) "x" + varYs <- newNames (length args) "y" + let patX = ConP constr $ map VarP varXs + let patY = ConP constr $ map VarP varYs + body <- eqDBody conArg coArg (zip3 varXs varYs args) + return $ Clause [patX, patY] (NormalB body) [] + eqDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ + eqDBody conArg coArg x = + [|liftM compList (sequence $(listE $ map (eqDB conArg coArg) x))|] + eqDB :: Name -> Name -> (Name, Name, Type) -> ExpQ + eqDB conArg coArg (x, y, tp) + | not (containsType tp (VarT conArg)) && + not (containsType tp (VarT coArg)) = + [| return $ compare $(varE x) $(varE y) |] + | otherwise = + case tp of + VarT a + | a == coArg -> [| pcompare $(varE x) $(varE y) |] + AppT (AppT ArrowT (VarT a)) _ + | a == conArg -> + [| withName (\v -> pcompare ($(varE x) v) ($(varE y) v)) |] + SigT tp' _ -> + eqDB conArg coArg (x, y, tp') + _ -> + if containsType tp (VarT conArg) then + [| compareD $(varE x) $(varE y) |] + else + [| pcompare $(varE x) $(varE y) |] + genLtClause (c, _) (d, _) = + clause [recP c [], recP d []] (normalB [| return LT |]) [] + genGtClause (c, _) (d, _) = + clause [recP c [], recP d []] (normalB [| return GT |]) [] \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Derive/Projections.hs b/compdata-param-master/src/Data/Comp/Param/Derive/Projections.hs new file mode 100755 index 0000000..d08d291 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Derive/Projections.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE TemplateHaskell, GADTs #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Derive.Projections +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Derive functions for signature projections. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Derive.Projections + ( + projn, + projectn, + deepProjectn + ) where + +import Language.Haskell.TH hiding (Cxt) +import Control.Monad (liftM) +import Data.Comp.Param.Ditraversable (Ditraversable) +import Data.Comp.Param.Term +import Data.Comp.Param.Algebra (appTSigFunM') +import Data.Comp.Param.Ops ((:+:)(..), (:<:)(..)) + +projn :: Int -> Q [Dec] +projn n = do + let p = mkName $ "proj" ++ show n + let gvars = map (\n -> mkName $ 'g' : show n) [1..n] + let avar = mkName "a" + let bvar = mkName "b" + let xvar = mkName "x" + let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar gvars avar bvar) []]] + sequence $ (sigD p $ genSig gvars avar bvar) : d + where genSig gvars avar bvar = do + let fvar = mkName "f" + let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars + let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a) + (map varT gvars) + let tp' = arrowT `appT` (varT fvar `appT` varT avar `appT` + varT bvar) + `appT` (conT ''Maybe `appT` + (tp `appT` varT avar `appT` varT bvar)) + forallT (map PlainTV $ fvar : avar : bvar : gvars) + (sequence cxt) tp' + genDecl x [g] a b = + [| liftM inj (proj $(varE x) + :: Maybe ($(varT g `appT` varT a `appT` varT b))) |] + genDecl x (g:gs) a b = + [| case (proj $(varE x) + :: Maybe ($(varT g `appT` varT a `appT` varT b))) of + Just y -> Just $ inj y + _ -> $(genDecl x gs a b) |] + genDecl _ _ _ _ = error "genDecl called with empty list" + +projectn :: Int -> Q [Dec] +projectn n = do + let p = mkName ("project" ++ show n) + let gvars = map (\n -> mkName $ 'g' : show n) [1..n] + let avar = mkName "a" + let bvar = mkName "b" + let xvar = mkName "x" + let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar n) []]] + sequence $ (sigD p $ genSig gvars avar bvar) : d + where genSig gvars avar bvar = do + let fvar = mkName "f" + let hvar = mkName "h" + let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars + let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a) + (map varT gvars) + let tp' = conT ''Cxt `appT` varT hvar `appT` varT fvar + `appT` varT avar `appT` varT bvar + let tp'' = arrowT `appT` tp' + `appT` (conT ''Maybe `appT` + (tp `appT` varT avar `appT` tp')) + forallT (map PlainTV $ hvar : fvar : avar : bvar : gvars) + (sequence cxt) tp'' + genDecl x n = [| case $(varE x) of + Hole _ -> Nothing + Var _ -> Nothing + In t -> $(varE $ mkName $ "proj" ++ show n) t |] + +deepProjectn :: Int -> Q [Dec] +deepProjectn n = do + let p = mkName ("deepProject" ++ show n) + let gvars = map (\n -> mkName $ 'g' : show n) [1..n] + let d = [funD p [clause [] (normalB $ genDecl n) []]] + sequence $ (sigD p $ genSig gvars) : d + where genSig gvars = do + let fvar = mkName "f" + let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars + let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a) + (map varT gvars) + let cxt' = classP ''Ditraversable [tp] + let tp' = arrowT `appT` (conT ''Term `appT` varT fvar) + `appT` (conT ''Maybe `appT` (conT ''Term `appT` tp)) + forallT (map PlainTV $ fvar : gvars) (sequence $ cxt' : cxt) tp' + genDecl n = [| appTSigFunM' $(varE $ mkName $ "proj" ++ show n) |] \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Derive/Show.hs b/compdata-param-master/src/Data/Comp/Param/Derive/Show.hs new file mode 100755 index 0000000..82eb133 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Derive/Show.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances, + ScopedTypeVariables, UndecidableInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Derive.Show +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Automatically derive instances of @ShowD@. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Derive.Show + ( + ShowD(..), + makeShowD + ) where + +import Data.Comp.Derive.Utils +import Data.Comp.Param.FreshM hiding (Name) +import qualified Data.Comp.Param.FreshM as FreshM +import Control.Monad +import Language.Haskell.TH hiding (Cxt, match) +import qualified Data.Traversable as T + +{-| Signature printing. An instance @ShowD f@ gives rise to an instance + @Show (Term f)@. -} +class ShowD f where + showD :: f FreshM.Name (FreshM String) -> FreshM String + +newtype Dummy = Dummy String + +instance Show Dummy where + show (Dummy s) = s + +{-| Derive an instance of 'ShowD' for a type constructor of any parametric + kind taking at least two arguments. -} +makeShowD :: Name -> Q [Dec] +makeShowD fname = do + -- Comments below apply to the example where name = T, args = [a,b,c], and + -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type + -- declaration: T a b c = X c | Y a c | Z (b -> c) + TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname + -- coArg = c (covariant difunctor argument) + let coArg :: Name = tyVarBndrName $ last args + -- conArg = b (contravariant difunctor argument) + let conArg :: Name = tyVarBndrName $ last $ init args + -- argNames = [a] + let argNames = map (VarT . tyVarBndrName) (init $ init args) + -- compType = T a + let complType = foldl AppT (ConT name) argNames + -- classType = Difunctor (T a) + let classType = AppT (ConT ''ShowD) complType + -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])] + constrs' :: [(Name,[Type])] <- mapM normalConExp constrs + showDDecl <- funD 'showD (map (showDClause conArg coArg) constrs') + let context = map (\arg -> ClassP ''Show [arg]) argNames + return [InstanceD context classType [showDDecl]] + where showDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ + showDClause conArg coArg (constr, args) = do + varXs <- newNames (length args) "x" + -- Pattern for the constructor + let patx = ConP constr $ map VarP varXs + body <- showDBody (nameBase constr) conArg coArg (zip varXs args) + return $ Clause [patx] (NormalB body) [] + showDBody :: String -> Name -> Name -> [(Name, Type)] -> ExpQ + showDBody constr conArg coArg x = + [|liftM (unwords . (constr :) . + map (\x -> if elem ' ' x then "(" ++ x ++ ")" else x)) + (sequence $(listE $ map (showDB conArg coArg) x))|] + showDB :: Name -> Name -> (Name, Type) -> ExpQ + showDB conArg coArg (x, tp) + | not (containsType tp (VarT conArg)) && + not (containsType tp (VarT coArg)) = + [| return $ show $(varE x) |] + | otherwise = + case tp of + VarT a + | a == coArg -> [| $(varE x) |] + AppT (AppT ArrowT (VarT a)) _ + | a == conArg -> + [| withName (\v -> do body <- $(varE x) v; + return $ "\\" ++ show v ++ " -> " ++ body) |] + SigT tp' _ -> + showDB conArg coArg (x, tp') + _ -> + if containsType tp (VarT conArg) then + [| showD $(varE x) |] + else + [| liftM show $ T.mapM (liftM Dummy) $(varE x) |] \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Derive/SmartAConstructors.hs b/compdata-param-master/src/Data/Comp/Param/Derive/SmartAConstructors.hs new file mode 100755 index 0000000..758523f --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Derive/SmartAConstructors.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Derive.SmartAConstructors +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Automatically derive smart constructors with annotations for difunctors. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Derive.SmartAConstructors + ( + smartAConstructors + ) where + +import Language.Haskell.TH hiding (Cxt) +import Data.Comp.Derive.Utils +import Data.Comp.Param.Ops +import Data.Comp.Param.Term +import Data.Comp.Param.Difunctor + +import Control.Monad + +{-| Derive smart constructors with annotations for a difunctor. The smart + constructors are similar to the ordinary constructors, but a + 'injectA . dimap Var id' is automatically inserted. -} +smartAConstructors :: Name -> Q [Dec] +smartAConstructors fname = do + TyConI (DataD _cxt _tname _targs constrs _deriving) <- abstractNewtypeQ $ reify fname + let cons = map abstractConType constrs + liftM concat $ mapM genSmartConstr cons + where genSmartConstr (name, args) = do + let bname = nameBase name + genSmartConstr' (mkName $ "iA" ++ bname) name args + genSmartConstr' sname name args = do + varNs <- newNames args "x" + varPr <- newName "_p" + let pats = map varP (varPr : varNs) + vars = map varE varNs + val = appE [|injectA $(varE varPr)|] $ + appE [|inj . dimap Var id|] $ foldl appE (conE name) vars + function = [funD sname [clause pats (normalB [|In $val|]) []]] + sequence function diff --git a/compdata-param-master/src/Data/Comp/Param/Derive/SmartConstructors.hs b/compdata-param-master/src/Data/Comp/Param/Derive/SmartConstructors.hs new file mode 100755 index 0000000..3d6cdc5 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Derive/SmartConstructors.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Derive.SmartConstructors +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Automatically derive smart constructors for difunctors. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Derive.SmartConstructors + ( + smartConstructors + ) where + +import Language.Haskell.TH hiding (Cxt) +import Data.Comp.Derive.Utils +import Data.Comp.Param.Sum +import Data.Comp.Param.Term +import Data.Comp.Param.Difunctor +import Control.Monad + +{-| Derive smart constructors for a difunctor. The smart constructors are + similar to the ordinary constructors, but a 'inject . dimap Var id' is + automatically inserted. -} +smartConstructors :: Name -> Q [Dec] +smartConstructors fname = do + TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname + let cons = map abstractConType constrs + liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons + where genSmartConstr targs tname (name, args) = do + let bname = nameBase name + genSmartConstr' targs tname (mkName $ 'i' : bname) name args + genSmartConstr' targs tname sname name args = do + varNs <- newNames args "x" + let pats = map varP varNs + vars = map varE varNs + val = foldl appE (conE name) vars + sig = genSig targs tname sname args + function = [funD sname [clause pats (normalB [|inject (dimap Var id $val)|]) []]] + sequence $ sig ++ function + genSig targs tname sname 0 = (:[]) $ do + hvar <- newName "h" + fvar <- newName "f" + avar <- newName "a" + bvar <- newName "b" + let targs' = init $ init targs + vars = hvar:fvar:avar:bvar:targs' + h = varT hvar + f = varT fvar + a = varT avar + b = varT bvar + ftype = foldl appT (conT tname) (map varT targs') + constr = classP ''(:<:) [ftype, f] + typ = foldl appT (conT ''Cxt) [h, f, a, b] + typeSig = forallT (map PlainTV vars) (sequence [constr]) typ + sigD sname typeSig + genSig _ _ _ _ = [] \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Desugar.hs b/compdata-param-master/src/Data/Comp/Param/Desugar.hs new file mode 100755 index 0000000..34b94d2 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Desugar.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, + UndecidableInstances, OverlappingInstances, Rank2Types, TypeOperators #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Desugar +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This modules defines the 'Desugar' type class for desugaring of terms. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Desugar where + +import Data.Comp.Param + + +-- |The desugaring term homomorphism. +class (Difunctor f, Difunctor g) => Desugar f g where + desugHom :: Hom f g + desugHom = desugHom' . fmap Hole + desugHom' :: f a (Cxt h g a b) -> Cxt h g a b + desugHom' x = appCxt (desugHom x) + +-- We make the lifting to sums explicit in order to make the Desugar +-- class work with the default instance declaration further below. +instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where + desugHom = caseD desugHom desugHom + +-- |Desugar a term. +desugar :: Desugar f g => Term f -> Term g +{-# INLINE desugar #-} +desugar (Term t) = Term (appHom desugHom t) + +-- |Lift desugaring to annotated terms. +desugarA :: (Difunctor f', Difunctor g', DistAnn f p f', DistAnn g p g', + Desugar f g) => Term f' -> Term g' +desugarA (Term t) = Term (appHom (propAnn desugHom) t) + +-- |Default desugaring instance. +instance (Difunctor f, Difunctor g, f :<: g) => Desugar f g where + desugHom = simpCxt . inj \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Difunctor.hs b/compdata-param-master/src/Data/Comp/Param/Difunctor.hs new file mode 100755 index 0000000..de09dcc --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Difunctor.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Difunctor +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines difunctors (Meijer, Hutton, FPCA '95), i.e. binary type +-- constructors that are contravariant in the first argument and covariant in +-- the second argument. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Difunctor + ( + difmap, + Difunctor(..) + ) where + +-- | This class represents difunctors, i.e. binary type constructors that are +-- contravariant in the first argument and covariant in the second argument. +class Difunctor f where + dimap :: (a -> b) -> (c -> d) -> f b c -> f a d + +{-| The canonical example of a difunctor. -} +instance Difunctor (->) where + dimap f g h = g . h . f + +difmap :: Difunctor f => (a -> b) -> f c a -> f c b +difmap = dimap id + +instance Difunctor f => Functor (f a) where + fmap = difmap \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Ditraversable.hs b/compdata-param-master/src/Data/Comp/Param/Ditraversable.hs new file mode 100755 index 0000000..e82bf86 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Ditraversable.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Ditraversable +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines traversable difunctors. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Ditraversable + ( + Ditraversable(..) + ) where + +import Data.Comp.Param.Difunctor + +{-| Difunctors representing data structures that can be traversed from left to + right. -} +class Difunctor f => Ditraversable f where + dimapM :: Monad m => (b -> m c) -> f a b -> m (f a c) + dimapM f = disequence . fmap f + disequence :: Monad m => f a (m b) -> m (f a b) + disequence = dimapM id \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Equality.hs b/compdata-param-master/src/Data/Comp/Param/Equality.hs new file mode 100755 index 0000000..56bf851 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Equality.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances, + UndecidableInstances, IncoherentInstances, GADTs #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Equality +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines equality for signatures, which lifts to equality for +-- terms. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Equality + ( + PEq(..), + EqD(..) + ) where + +import Data.Comp.Param.Term +import Data.Comp.Param.Sum +import Data.Comp.Param.Ops +import Data.Comp.Param.Difunctor +import Data.Comp.Param.FreshM +import Control.Monad (liftM) + +-- |Equality on parametric values. The equality test is performed inside the +-- 'FreshM' monad for generating fresh identifiers. +class PEq a where + peq :: a -> a -> FreshM Bool + +instance PEq a => PEq [a] where + peq l1 l2 + | length l1 /= length l2 = return False + | otherwise = liftM or $ mapM (uncurry peq) $ zip l1 l2 + +instance Eq a => PEq a where + peq x y = return $ x == y + +{-| Signature equality. An instance @EqD f@ gives rise to an instance + @Eq (Term f)@. The equality test is performed inside the 'FreshM' monad for + generating fresh identifiers. -} +class EqD f where + eqD :: PEq a => f Name a -> f Name a -> FreshM Bool + +{-| 'EqD' is propagated through sums. -} +instance (EqD f, EqD g) => EqD (f :+: g) where + eqD (Inl x) (Inl y) = eqD x y + eqD (Inr x) (Inr y) = eqD x y + eqD _ _ = return False + +{-| From an 'EqD' difunctor an 'Eq' instance of the corresponding term type can + be derived. -} +instance EqD f => EqD (Cxt h f) where + eqD (In e1) (In e2) = eqD e1 e2 + eqD (Hole h1) (Hole h2) = peq h1 h2 + eqD (Var p1) (Var p2) = peq p1 p2 + eqD _ _ = return False + +instance (EqD f, PEq a) => PEq (Cxt h f Name a) where + peq = eqD + +{-| Equality on terms. -} +instance (Difunctor f, EqD f) => Eq (Term f) where + (==) (Term x) (Term y) = evalFreshM $ eqD x y \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/FreshM.hs b/compdata-param-master/src/Data/Comp/Param/FreshM.hs new file mode 100755 index 0000000..08dfd72 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/FreshM.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.FreshM +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines a monad for generating fresh, abstract names, useful +-- e.g. for defining equality on terms. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.FreshM + ( + FreshM, + Name, + withName, + evalFreshM + ) where + +import Control.Monad.Reader +import Control.Applicative + +-- |Monad for generating fresh (abstract) names. +newtype FreshM a = FreshM{unFreshM :: Reader Int a} + deriving (Monad, Applicative,Functor) + +-- |Abstract notion of a name (the constructor is hidden). +newtype Name = Name Int + deriving Eq + +instance Show Name where + show (Name x) = names !! x + where baseNames = ['a'..'z'] + names = map (:[]) baseNames ++ names' 1 + names' n = map (: show n) baseNames ++ names' (n + 1) + +instance Ord Name where + compare (Name x) (Name y) = compare x y + +-- |Run the given computation with the next available name. +withName :: (Name -> FreshM a) -> FreshM a +withName m = do name <- FreshM (asks Name) + FreshM $ local ((+) 1) $ unFreshM $ m name + +-- |Evaluate a computation that uses fresh names. +evalFreshM :: FreshM a -> a +evalFreshM (FreshM m) = runReader m 0 diff --git a/compdata-param-master/src/Data/Comp/Param/Multi.hs b/compdata-param-master/src/Data/Comp/Param/Multi.hs new file mode 100755 index 0000000..29aaa10 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi.hs @@ -0,0 +1,34 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Patrick Bahr , Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines the infrastructure necessary to use +-- /Generalised Parametric Compositional Data Types/. Generalised Parametric +-- Compositional Data Types is an extension of Compositional Data Types with +-- parametric higher-order abstract syntax (PHOAS) for usage with binders, and +-- GADTs. Generalised Parametric Compositional Data Types combines Generalised +-- Compositional Data Types ("Data.Comp.Multi") and Parametric Compositional +-- Data Types ("Data.Comp.Param"). Examples of usage are bundled with the +-- package in the library @examples\/Examples\/Param.Multi@. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Multi ( + module Data.Comp.Param.Multi.Term + , module Data.Comp.Param.Multi.Algebra + , module Data.Comp.Param.Multi.HDifunctor + , module Data.Comp.Param.Multi.Sum + , module Data.Comp.Param.Multi.Annotation + , module Data.Comp.Param.Multi.Equality + ) where + +import Data.Comp.Param.Multi.Term +import Data.Comp.Param.Multi.Algebra +import Data.Comp.Param.Multi.HDifunctor +import Data.Comp.Param.Multi.Sum +import Data.Comp.Param.Multi.Annotation +import Data.Comp.Param.Multi.Equality diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Algebra.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Algebra.hs new file mode 100755 index 0000000..9a85970 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Algebra.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE GADTs, Rank2Types, ScopedTypeVariables, TypeOperators, + FlexibleContexts, CPP, KindSignatures #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Algebra +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines the notion of algebras and catamorphisms, and their +-- generalizations to e.g. monadic versions and other (co)recursion schemes. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.Algebra ( + -- * Algebras & Catamorphisms + Alg, + free, + cata, + cata', + appCxt, + + -- * Monadic Algebras & Catamorphisms + AlgM, +-- algM, + freeM, + cataM, + AlgM', + Compose(..), + freeM', + cataM', + + -- * Term Homomorphisms + CxtFun, + SigFun, + Hom, + appHom, + appHom', + compHom, + appSigFun, + appSigFun', + compSigFun, + hom, + compAlg, + + -- * Monadic Term Homomorphisms + CxtFunM, + SigFunM, + HomM, + sigFunM, + hom', + appHomM, + appTHomM, + appHomM', + appTHomM', + homM, + appSigFunM, + appTSigFunM, + appSigFunM', + appTSigFunM', + compHomM, + compSigFunM, + compAlgM, + compAlgM' + ) where + +import Prelude hiding (sequence, mapM) +import Control.Monad hiding (sequence, mapM) +import Data.Functor.Compose -- Functor composition +import Data.Comp.Param.Multi.Term +import Data.Comp.Param.Multi.HDifunctor +import Data.Comp.Param.Multi.HDitraversable + +{-| This type represents an algebra over a difunctor @f@ and carrier @a@. -} +type Alg f a = f a a :-> a + +{-| Construct a catamorphism for contexts over @f@ with holes of type @b@, from + the given algebra. -} +free :: forall h f a b. HDifunctor f + => Alg f a -> (b :-> a) -> Cxt h f a b :-> a +free f g = run + where run :: Cxt h f a b :-> a + run (In t) = f (hfmap run t) + run (Hole x) = g x + run (Var p) = p + +{-| Construct a catamorphism from the given algebra. -} +cata :: forall f a. HDifunctor f => Alg f a -> Term f :-> a +{-# NOINLINE [1] cata #-} +cata f (Term t) = run t + where run :: Trm f a :-> a + run (In t) = f (hfmap run t) + run (Var x) = x + +{-| A generalisation of 'cata' from terms over @f@ to contexts over @f@, where + the holes have the type of the algebra carrier. -} +cata' :: HDifunctor f => Alg f a -> Cxt h f a a :-> a +{-# INLINE cata' #-} +cata' f = free f id + +{-| This function applies a whole context into another context. -} +appCxt :: HDifunctor f => Cxt Hole f a (Cxt h f a b) :-> Cxt h f a b +appCxt (In t) = In (hfmap appCxt t) +appCxt (Hole x) = x +appCxt (Var p) = Var p + +{-| This type represents a monadic algebra. It is similar to 'Alg' but + the return type is monadic. -} +type AlgM m f a = NatM m (f a a) a + +{-| Construct a monadic catamorphism for contexts over @f@ with holes of type + @b@, from the given monadic algebra. -} +freeM :: forall m h f a b. (HDitraversable f, Monad m) + => AlgM m f a -> NatM m b a -> NatM m (Cxt h f a b) a +freeM f g = run + where run :: NatM m (Cxt h f a b) a + run (In t) = f =<< hdimapM run t + run (Hole x) = g x + run (Var p) = return p + +{-| Construct a monadic catamorphism from the given monadic algebra. -} +cataM :: forall m f a. (HDitraversable f, Monad m) + => AlgM m f a -> NatM m (Term f) a +{-# NOINLINE [1] cataM #-} +cataM algm (Term t) = run t + where run :: NatM m (Trm f a) a + run (In t) = algm =<< hdimapM run t + run (Var x) = return x + +{-| This type represents a monadic algebra, but where the covariant argument is + also a monadic computation. -} +type AlgM' m f a = NatM m (f a (Compose m a)) a + +{-| Construct a monadic catamorphism for contexts over @f@ with holes of type + @b@, from the given monadic algebra. -} +freeM' :: forall m h f a b. (HDifunctor f, Monad m) + => AlgM' m f a -> NatM m b a -> NatM m (Cxt h f a b) a +freeM' f g = run + where run :: NatM m (Cxt h f a b) a + run (In t) = f $ hfmap (Compose . run) t + run (Hole x) = g x + run (Var p) = return p + +{-| Construct a monadic catamorphism from the given monadic algebra. -} +cataM' :: forall m f a. (HDifunctor f, Monad m) + => AlgM' m f a -> NatM m (Term f) a +{-# NOINLINE [1] cataM' #-} +cataM' algm (Term t) = run t + where run :: NatM m (Trm f a) a + run (In t) = algm $ hfmap (Compose . run) t + run (Var x) = return x + +{-| This type represents a signature function. -} +type SigFun f g = forall (a :: * -> *) (b :: * -> *) . f a b :-> g a b + +{-| This type represents a context function. -} +type CxtFun f g = forall h. SigFun (Cxt h f) (Cxt h g) + +{-| This type represents a term homomorphism. -} +type Hom f g = SigFun f (Context g) + +{-| Apply a term homomorphism recursively to a term/context. -} +appHom :: forall f g. (HDifunctor f, HDifunctor g) => Hom f g -> CxtFun f g +{-# INLINE [1] appHom #-} +appHom f = run where + run :: CxtFun f g + run (In t) = appCxt (f (hfmap run t)) + run (Hole x) = Hole x + run (Var p) = Var p + +-- | Apply a term homomorphism recursively to a term/context. This is +-- a top-down variant of 'appHom'. +appHom' :: forall f g. (HDifunctor g) + => Hom f g -> CxtFun f g +{-# INLINE [1] appHom' #-} +appHom' f = run where + run :: CxtFun f g + run (In t) = appCxt (hfmapCxt run (f t)) + run (Hole x) = Hole x + run (Var p) = Var p + +{-| Compose two term homomorphisms. -} +compHom :: (HDifunctor g, HDifunctor h) + => Hom g h -> Hom f g -> Hom f h +compHom f g = appHom f . g + +{-| Compose an algebra with a term homomorphism to get a new algebra. -} +compAlg :: (HDifunctor f, HDifunctor g) => Alg g a -> Hom f g -> Alg f a +compAlg alg talg = cata' alg . talg + +{-| This function applies a signature function to the given context. -} +appSigFun :: forall f g. (HDifunctor f) => SigFun f g -> CxtFun f g +appSigFun f = run where + run :: CxtFun f g + run (In t) = In (f (hfmap run t)) + run (Hole x) = Hole x + run (Var p) = Var p + +{-| This function applies a signature function to the given context. -} +appSigFun' :: forall f g. (HDifunctor g) => SigFun f g -> CxtFun f g +appSigFun' f = run where + run :: CxtFun f g + run (In t) = In (hfmap run (f t)) + run (Hole x) = Hole x + run (Var p) = Var p + +{-| This function composes two signature functions. -} +compSigFun :: SigFun g h -> SigFun f g -> SigFun f h +compSigFun f g = f . g + +{-| Lifts the given signature function to the canonical term homomorphism. -} +hom :: HDifunctor g => SigFun f g -> Hom f g +hom f = simpCxt . f + +{-| This type represents a monadic signature function. -} +type SigFunM m f g = forall (a :: * -> *) (b :: * -> *) . NatM m (f a b) (g a b) + +{-| This type represents a monadic context function. -} +type CxtFunM m f g = forall h . SigFunM m (Cxt h f) (Cxt h g) + +{-| This type represents a monadic term homomorphism. -} +type HomM m f g = SigFunM m f (Cxt Hole g) + + +{-| Lift the given signature function to a monadic signature function. Note that + term homomorphisms are instances of signature functions. Hence this function + also applies to term homomorphisms. -} +sigFunM :: Monad m => SigFun f g -> SigFunM m f g +sigFunM f = return . f + +{-| Lift the give monadic signature function to a monadic term homomorphism. -} +hom' :: (HDifunctor f, HDifunctor g, Monad m) + => SigFunM m f g -> HomM m f g +hom' f = liftM (In . hfmap Hole) . f + +{-| Lift the given signature function to a monadic term homomorphism. -} +homM :: (HDifunctor g, Monad m) => SigFun f g -> HomM m f g +homM f = sigFunM $ hom f + +{-| Apply a monadic term homomorphism recursively to a term/context. -} +appHomM :: forall f g m. (HDitraversable f, Monad m, HDifunctor g) + => HomM m f g -> CxtFunM m f g +{-# NOINLINE [1] appHomM #-} +appHomM f = run + where run :: CxtFunM m f g + run (In t) = liftM appCxt (f =<< hdimapM run t) + run (Hole x) = return (Hole x) + run (Var p) = return (Var p) + +{-| A restricted form of |appHomM| which only works for terms. -} +appTHomM :: (HDitraversable f, Monad m, ParamFunctor m, HDifunctor g) + => HomM m f g -> Term f i -> m (Term g i) +appTHomM f (Term t) = termM (appHomM f t) + +-- | Apply a monadic term homomorphism recursively to a +-- term/context. This is a top-down variant of 'appHomM'. +appHomM' :: forall f g m. (HDitraversable g, Monad m) + => HomM m f g -> CxtFunM m f g +{-# NOINLINE [1] appHomM' #-} +appHomM' f = run + where run :: CxtFunM m f g + run (In t) = liftM appCxt (hdimapMCxt run =<< f t) + run (Hole x) = return (Hole x) + run (Var p) = return (Var p) + +{-| A restricted form of |appHomM'| which only works for terms. -} +appTHomM' :: (HDitraversable g, Monad m, ParamFunctor m, HDifunctor g) + => HomM m f g -> Term f i -> m (Term g i) +appTHomM' f (Term t) = termM (appHomM' f t) + +{-| This function applies a monadic signature function to the given context. -} +appSigFunM :: forall m f g. (HDitraversable f, Monad m) + => SigFunM m f g -> CxtFunM m f g +appSigFunM f = run + where run :: CxtFunM m f g + run (In t) = liftM In (f =<< hdimapM run t) + run (Hole x) = return (Hole x) + run (Var p) = return (Var p) + +{-| A restricted form of |appSigFunM| which only works for terms. -} +appTSigFunM :: (HDitraversable f, Monad m, ParamFunctor m, HDifunctor g) + => SigFunM m f g -> Term f i -> m (Term g i) +appTSigFunM f (Term t) = termM (appSigFunM f t) + +-- | This function applies a monadic signature function to the given +-- context. This is a top-down variant of 'appSigFunM'. +appSigFunM' :: forall m f g. (HDitraversable g, Monad m) + => SigFunM m f g -> CxtFunM m f g +appSigFunM' f = run + where run :: CxtFunM m f g + run (In t) = liftM In (hdimapM run =<< f t) + run (Hole x) = return (Hole x) + run (Var p) = return (Var p) + +{-| A restricted form of |appSigFunM'| which only works for terms. -} +appTSigFunM' :: (HDitraversable g, Monad m, ParamFunctor m, HDifunctor g) + => SigFunM m f g -> Term f i -> m (Term g i) +appTSigFunM' f (Term t) = termM (appSigFunM' f t) + +{-| Compose two monadic term homomorphisms. -} +compHomM :: (HDitraversable g, HDifunctor h, Monad m) + => HomM m g h -> HomM m f g -> HomM m f h +compHomM f g = appHomM f <=< g + +{-| Compose a monadic algebra with a monadic term homomorphism to get a new + monadic algebra. -} +compAlgM :: (HDitraversable g, Monad m) => AlgM m g a -> HomM m f g -> AlgM m f a +compAlgM alg talg = freeM alg return <=< talg + +{-| Compose a monadic algebra with a term homomorphism to get a new monadic + algebra. -} +compAlgM' :: (HDitraversable g, Monad m) => AlgM m g a -> Hom f g -> AlgM m f a +compAlgM' alg talg = freeM alg return . talg + +{-| This function composes two monadic signature functions. -} +compSigFunM :: Monad m => SigFunM m g h -> SigFunM m f g -> SigFunM m f h +compSigFunM f g a = g a >>= f + +{- +#ifndef NO_RULES +{-# RULES + "cata/appHom" forall (a :: Alg g d) (h :: Hom f g) x. + cata a (appHom h x) = cata (compAlg a h) x; + + "appHom/appHom" forall (a :: Hom g h) (h :: Hom f g) x. + appHom a (appHom h x) = appHom (compHom a h) x; #-} + +{- +{-# RULES + "cataM/appHomM" forall (a :: AlgM m g d) (h :: HomM m f g d) x. + appHomM h x >>= cataM a = cataM (compAlgM a h) x; + + "cataM/appHom" forall (a :: AlgM m g d) (h :: Hom f g) x. + cataM a (appHom h x) = cataM (compAlgM' a h) x; + + "appHomM/appHomM" forall (a :: HomM m g h b) (h :: HomM m f g b) x. + appHomM h x >>= appHomM a = appHomM (compHomM a h) x; #-} + +{-# RULES + "cata/build" forall alg (g :: forall a . Alg f a -> a) . + cata alg (build g) = g alg #-} +-} +#endif +-} diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Annotation.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Annotation.hs new file mode 100755 index 0000000..d990dd0 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Annotation.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances, + UndecidableInstances, Rank2Types, GADTs, ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Annotation +-- Copyright : (c) 2010-2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines annotations on signatures. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.Annotation + ( + (:&:) (..), + (:*:) (..), + DistAnn (..), + RemA (..), + liftA, + liftA', + stripA, + propAnn, + propAnnM, + ann, + project' + ) where + +import qualified Data.Comp.Ops as O +import Data.Comp.Param.Multi.HDifunctor +import Data.Comp.Param.Multi.Term +import Data.Comp.Param.Multi.Sum +import Data.Comp.Param.Multi.Ops +import Data.Comp.Param.Multi.Algebra + +import Control.Monad + +{-| Transform a function with a domain constructed from a higher-order difunctor + to a function with a domain constructed with the same higher-order difunctor, + but with an additional annotation. -} +liftA :: (RemA s s') => (s' a b :-> t) -> s a b :-> t +liftA f v = f (remA v) + +{-| Transform a function with a domain constructed from a higher-order difunctor + to a function with a domain constructed with the same higher-order difunctor, + but with an additional annotation. -} +liftA' :: (DistAnn s' p s, HDifunctor s') + => (s' a b :-> Cxt h s' c d) -> s a b :-> Cxt h s c d +liftA' f v = let v' O.:&: p = projectA v + in ann p (f v') + +{-| Strip the annotations from a term over a higher-order difunctor with + annotations. -} +stripA :: (RemA g f, HDifunctor g) => CxtFun g f +stripA = appSigFun remA + +{-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism + over the same signatures, but extended with annotations. -} +propAnn :: (DistAnn f p f', DistAnn g p g', HDifunctor g) + => Hom f g -> Hom f' g' +propAnn hom f' = ann p (hom f) + where f O.:&: p = projectA f' + +{-| Lift a monadic term homomorphism over signatures @f@ and @g@ to a monadic + term homomorphism over the same signatures, but extended with annotations. -} +propAnnM :: (DistAnn f p f', DistAnn g p g', HDifunctor g, Monad m) + => HomM m f g -> HomM m f' g' +propAnnM hom f' = liftM (ann p) (hom f) + where f O.:&: p = projectA f' + +{-| Annotate each node of a term with a constant value. -} +ann :: (DistAnn f p g, HDifunctor f) => p -> CxtFun f g +ann c = appSigFun (injectA c) + +{-| This function is similar to 'project' but applies to signatures + with an annotation which is then ignored. -} +project' :: (RemA f f', s :<: f') => Cxt h f a b i -> Maybe (s a (Cxt h f a b) i) +project' (In x) = proj $ remA x +project' _ = Nothing diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Derive.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Derive.hs new file mode 100755 index 0000000..3fa339a --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Derive.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Derive +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module contains functionality for automatically deriving boilerplate +-- code using Template Haskell. Examples include instances of 'HDifunctor', +-- 'ShowHD', and 'EqHD'. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.Derive + ( + derive, + -- |Derive boilerplate instances for parametric signatures, i.e. + -- signatures for parametric compositional data types. + + -- ** EqHD + module Data.Comp.Param.Multi.Derive.Equality, + -- ** OrdHD + module Data.Comp.Param.Multi.Derive.Ordering, + -- ** ShowHD + module Data.Comp.Param.Multi.Derive.Show, + -- ** HDifunctor + module Data.Comp.Param.Multi.Derive.HDifunctor, + -- ** Smart Constructors + module Data.Comp.Param.Multi.Derive.SmartConstructors, + -- ** Smart Constructors w/ Annotations + module Data.Comp.Param.Multi.Derive.SmartAConstructors, + -- ** Lifting to Sums + liftSum + ) where + +import Data.Comp.Derive.Utils (derive, liftSumGen) +import Data.Comp.Param.Multi.Derive.Equality +import Data.Comp.Param.Multi.Derive.Ordering +import Data.Comp.Param.Multi.Derive.Show +import Data.Comp.Param.Multi.Derive.HDifunctor +import Data.Comp.Param.Multi.Derive.SmartConstructors +import Data.Comp.Param.Multi.Derive.SmartAConstructors +import Data.Comp.Param.Multi.Ops ((:+:), caseHD) + +import Language.Haskell.TH + +{-| Given the name of a type class, where the first parameter is a higher-order + difunctor, lift it to sums of higher-order difunctors. Example: + @class ShowHD f where ...@ is lifted as + @instance (ShowHD f, ShowHD g) => ShowHD (f :+: g) where ... @. -} +liftSum :: Name -> Q [Dec] +liftSum = liftSumGen 'caseHD ''(:+:) diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Equality.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Equality.hs new file mode 100755 index 0000000..6d9be4f --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Equality.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances, + ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Derive.Equality +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Automatically derive instances of @EqHD@. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Multi.Derive.Equality + ( + EqHD(..), + makeEqHD + ) where + +import Data.Comp.Derive.Utils +import Data.Comp.Param.Multi.FreshM hiding (Name) +import Data.Comp.Param.Multi.Equality +import Control.Monad +import Language.Haskell.TH hiding (Cxt, match) + +{-| Derive an instance of 'EqHD' for a type constructor of any parametric + kind taking at least three arguments. -} +makeEqHD :: Name -> Q [Dec] +makeEqHD fname = do + TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname + let args' = init args + -- covariant argument + let coArg :: Name = tyVarBndrName $ last args' + -- contravariant argument + let conArg :: Name = tyVarBndrName $ last $ init args' + let argNames = map (VarT . tyVarBndrName) (init $ init args') + let complType = foldl AppT (ConT name) argNames + let classType = AppT (ConT ''EqHD) complType + constrs' :: [(Name,[Type])] <- mapM normalConExp constrs + let defC = if length constrs < 2 then + [] + else + [clause [wildP,wildP] (normalB [|return False|]) []] + eqHDDecl <- funD 'eqHD (map (eqHDClause conArg coArg) constrs' ++ defC) + let context = map (\arg -> ClassP ''Eq [arg]) argNames + return [InstanceD context classType [eqHDDecl]] + where eqHDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ + eqHDClause conArg coArg (constr, args) = do + varXs <- newNames (length args) "x" + varYs <- newNames (length args) "y" + -- Patterns for the constructors + let patx = ConP constr $ map VarP varXs + let paty = ConP constr $ map VarP varYs + body <- eqHDBody conArg coArg (zip3 varXs varYs args) + return $ Clause [patx,paty] (NormalB body) [] + eqHDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ + eqHDBody conArg coArg x = + [|liftM and (sequence $(listE $ map (eqHDB conArg coArg) x))|] + eqHDB :: Name -> Name -> (Name, Name, Type) -> ExpQ + eqHDB conArg coArg (x, y, tp) + | not (containsType tp (VarT conArg)) && + not (containsType tp (VarT coArg)) = + [| return $ $(varE x) == $(varE y) |] + | otherwise = + case tp of + AppT (VarT a) _ + | a == coArg -> [| peq $(varE x) $(varE y) |] + AppT (AppT ArrowT (AppT (VarT a) _)) _ + | a == conArg -> + [| withName (\v -> peq ($(varE x) $ nameCoerce v) ($(varE y) $ nameCoerce v)) |] + SigT tp' _ -> + eqHDB conArg coArg (x, y, tp') + _ -> + if containsType tp (VarT conArg) then + [| eqHD $(varE x) $(varE y) |] + else + [| peq $(varE x) $(varE y) |] diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Derive/HDifunctor.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/HDifunctor.hs new file mode 100755 index 0000000..7d45626 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/HDifunctor.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Derive.HDifunctor +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Automatically derive instances of @HDifunctor@. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.Derive.HDifunctor + ( + HDifunctor, + makeHDifunctor + ) where + +import Data.Comp.Derive.Utils +import Data.Comp.Param.Multi.HDifunctor +import Language.Haskell.TH + +{-| Derive an instance of 'HDifunctor' for a type constructor of any parametric + kind taking at least three arguments. -} +makeHDifunctor :: Name -> Q [Dec] +makeHDifunctor fname = do + TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname + let args' = init args + -- covariant argument + let coArg :: Name = tyVarBndrName $ last args' + -- contravariant argument + let conArg :: Name = tyVarBndrName $ last $ init args' + let argNames = map (VarT . tyVarBndrName) (init $ init args') + let complType = foldl AppT (ConT name) argNames + let classType = AppT (ConT ''HDifunctor) complType + constrs' :: [(Name,[Type])] <- mapM normalConExp constrs + hdimapDecl <- funD 'hdimap (map (hdimapClause conArg coArg) constrs') + return [InstanceD [] classType [hdimapDecl]] + where hdimapClause :: Name -> Name -> (Name,[Type]) -> ClauseQ + hdimapClause conArg coArg (constr, args) = do + fn <- newName "_f" + gn <- newName "_g" + varNs <- newNames (length args) "x" + let f = varE fn + let g = varE gn + let fp = VarP fn + let gp = VarP gn + -- Pattern for the constructor + let pat = ConP constr $ map VarP varNs + body <- hdimapArgs conArg coArg f g (zip varNs args) (conE constr) + return $ Clause [fp, gp, pat] (NormalB body) [] + hdimapArgs :: Name -> Name -> ExpQ -> ExpQ + -> [(Name, Type)] -> ExpQ -> ExpQ + hdimapArgs _ _ _ _ [] acc = + acc + hdimapArgs conArg coArg f g ((x,tp):tps) acc = + hdimapArgs conArg coArg f g tps + (acc `appE` (hdimapArg conArg coArg tp f g `appE` varE x)) + hdimapArg :: Name -> Name -> Type -> ExpQ -> ExpQ -> ExpQ + hdimapArg conArg coArg tp f g + | not (containsType tp (VarT conArg)) && + not (containsType tp (VarT coArg)) = [| id |] + | otherwise = + case tp of + AppT (VarT a) _ | a == conArg -> f + | a == coArg -> g + AppT (AppT ArrowT tp1) tp2 -> do + xn <- newName "x" + let ftp1 = hdimapArg conArg coArg tp1 f g + let ftp2 = hdimapArg conArg coArg tp2 f g + lamE [varP xn] + (infixE (Just ftp2) + [|(.)|] + (Just $ infixE (Just $ varE xn) + [|(.)|] + (Just ftp1))) + SigT tp' _ -> + hdimapArg conArg coArg tp' f g + _ -> + if containsType tp (VarT conArg) then + [| hdimap $f $g |] + else + [| fmap $g |] diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Injections.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Injections.hs new file mode 100755 index 0000000..68f5d06 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Injections.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Derive.Injections +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Derive functions for signature injections. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.Derive.Injections + ( + injn, + injectn, + deepInjectn + ) where + +import Language.Haskell.TH hiding (Cxt) +import Data.Comp.Param.Multi.HDifunctor +import Data.Comp.Param.Multi.Term +import Data.Comp.Param.Multi.Algebra (CxtFun, appSigFun) +import Data.Comp.Param.Multi.Ops ((:+:)(..), (:<:)(..)) + +injn :: Int -> Q [Dec] +injn n = do + let i = mkName $ "inj" ++ show n + let fvars = map (\n -> mkName $ 'f' : show n) [1..n] + let gvar = mkName "g" + let avar = mkName "a" + let bvar = mkName "b" + let ivar = mkName "i" + let xvar = mkName "x" + let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]] + sequence $ sigD i (genSig fvars gvar avar bvar ivar) : d + where genSig fvars gvar avar bvar ivar = do + let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars + let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a) + (map varT fvars) + let tp' = arrowT `appT` (tp `appT` varT avar `appT` + varT bvar `appT` varT ivar) + `appT` (varT gvar `appT` varT avar `appT` + varT bvar `appT` varT ivar) + forallT (map PlainTV $ gvar : avar : bvar : ivar : fvars) + (sequence cxt) tp' + genDecl x n = [| case $(varE x) of + Inl x -> $(varE $ mkName "inj") x + Inr x -> $(varE $ mkName $ "inj" ++ + if n > 2 then show (n - 1) else "") x |] +injectn :: Int -> Q [Dec] +injectn n = do + let i = mkName ("inject" ++ show n) + let fvars = map (\n -> mkName $ 'f' : show n) [1..n] + let gvar = mkName "g" + let avar = mkName "a" + let bvar = mkName "b" + let ivar = mkName "i" + let d = [funD i [clause [] (normalB $ genDecl n) []]] + sequence $ sigD i (genSig fvars gvar avar bvar ivar) : d + where genSig fvars gvar avar bvar ivar = do + let hvar = mkName "h" + let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars + let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a) + (map varT fvars) + let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar + `appT` varT avar `appT` varT bvar + let tp'' = arrowT `appT` (tp `appT` varT avar `appT` + tp' `appT` varT ivar) + `appT` (tp' `appT` varT ivar) + forallT (map PlainTV $ hvar : gvar : avar : bvar : ivar : fvars) + (sequence cxt) tp'' + genDecl n = [| In . $(varE $ mkName $ "inj" ++ show n) |] + +deepInjectn :: Int -> Q [Dec] +deepInjectn n = do + let i = mkName ("deepInject" ++ show n) + let fvars = map (\n -> mkName $ 'f' : show n) [1..n] + let gvar = mkName "g" + let d = [funD i [clause [] (normalB $ genDecl n) []]] + sequence $ sigD i (genSig fvars gvar) : d + where genSig fvars gvar = do + let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars + let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a) + (map varT fvars) + let cxt' = classP ''HDifunctor [tp] + let tp' = conT ''CxtFun `appT` tp `appT` varT gvar + forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp' + genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |] diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Derive/LiftSum.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/LiftSum.hs new file mode 100755 index 0000000..f8c3815 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/LiftSum.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Derive.LiftSum +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Lift a class declaration for higher-order difunctors to sums of higher-order +-- difunctors. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.Derive.LiftSum + ( + liftSum, + caseHD + ) where + +import Language.Haskell.TH hiding (Cxt) +import Data.Comp.Derive.Utils +import Data.Comp.Param.Multi.Sum +import Data.Comp.Param.Multi.Ops ((:+:)(..)) + +{-| Given the name of a type class, where the first parameter is a higher-order + difunctor, lift it to sums of higher-order difunctors. Example: + @class ShowHD f where ...@ is lifted as + @instance (ShowHD f, ShowHD g) => ShowHD (f :+: g) where ... @. -} +liftSum :: Name -> Q [Dec] +liftSum = liftSumGen 'caseHD ''(:+:) + +{-| Utility function to case on a higher-order difunctor sum, without exposing + the internal representation of sums. -} +caseHD :: (f a b i -> c) -> (g a b i -> c) -> (f :+: g) a b i -> c +caseHD f g x = case x of + Inl x -> f x + Inr x -> g x diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Ordering.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Ordering.hs new file mode 100755 index 0000000..44af731 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Ordering.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances, + ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Derive.Ordering +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Automatically derive instances of @OrdHD@. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Multi.Derive.Ordering + ( + OrdHD(..), + makeOrdHD + ) where + +import Data.Comp.Param.Multi.FreshM hiding (Name) +import Data.Comp.Param.Multi.Ordering +import Data.Comp.Derive.Utils +import Data.Maybe +import Data.List +import Language.Haskell.TH hiding (Cxt) +import Control.Monad (liftM) + +compList :: [Ordering] -> Ordering +compList = fromMaybe EQ . find (/= EQ) + +{-| Derive an instance of 'OrdHD' for a type constructor of any parametric + kind taking at least three arguments. -} +makeOrdHD :: Name -> Q [Dec] +makeOrdHD fname = do + TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname + let args' = init args + -- covariant argument + let coArg :: Name = tyVarBndrName $ last args' + -- contravariant argument + let conArg :: Name = tyVarBndrName $ last $ init args' + let argNames = map (VarT . tyVarBndrName) (init $ init args') + let complType = foldl AppT (ConT name) argNames + let classType = AppT (ConT ''OrdHD) complType + constrs' :: [(Name,[Type])] <- mapM normalConExp constrs + compareHDDecl <- funD 'compareHD (compareHDClauses conArg coArg constrs') + let context = map (\arg -> ClassP ''Ord [arg]) argNames + return [InstanceD context classType [compareHDDecl]] + where compareHDClauses :: Name -> Name -> [(Name,[Type])] -> [ClauseQ] + compareHDClauses _ _ [] = [] + compareHDClauses conArg coArg constrs = + let constrs' = constrs `zip` [1..] + constPairs = [(x,y)| x<-constrs', y <- constrs'] + in map (genClause conArg coArg) constPairs + genClause conArg coArg ((c,n),(d,m)) + | n == m = genEqClause conArg coArg c + | n < m = genLtClause c d + | otherwise = genGtClause c d + genEqClause :: Name -> Name -> (Name,[Type]) -> ClauseQ + genEqClause conArg coArg (constr, args) = do + varXs <- newNames (length args) "x" + varYs <- newNames (length args) "y" + let patX = ConP constr $ map VarP varXs + let patY = ConP constr $ map VarP varYs + body <- eqDBody conArg coArg (zip3 varXs varYs args) + return $ Clause [patX, patY] (NormalB body) [] + eqDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ + eqDBody conArg coArg x = + [|liftM compList (sequence $(listE $ map (eqDB conArg coArg) x))|] + eqDB :: Name -> Name -> (Name, Name, Type) -> ExpQ + eqDB conArg coArg (x, y, tp) + | not (containsType tp (VarT conArg)) && + not (containsType tp (VarT coArg)) = + [| return $ compare $(varE x) $(varE y) |] + | otherwise = + case tp of + AppT (VarT a) _ + | a == coArg -> [| pcompare $(varE x) $(varE y) |] + AppT (AppT ArrowT (AppT (VarT a) _)) _ + | a == conArg -> + [| withName (\v -> pcompare ($(varE x) $ nameCoerce v) + ($(varE y) $ nameCoerce v)) |] + SigT tp' _ -> + eqDB conArg coArg (x, y, tp') + _ -> + if containsType tp (VarT conArg) then + [| compareHD $(varE x) $(varE y) |] + else + [| pcompare $(varE x) $(varE y) |] + genLtClause (c, _) (d, _) = + clause [recP c [], recP d []] (normalB [| return LT |]) [] + genGtClause (c, _) (d, _) = + clause [recP c [], recP d []] (normalB [| return GT |]) [] diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Projections.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Projections.hs new file mode 100755 index 0000000..81f8212 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Projections.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE TemplateHaskell, GADTs #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Derive.Projections +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Derive functions for signature projections. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.Derive.Projections + ( + projn, + projectn, + deepProjectn + ) where + +import Language.Haskell.TH hiding (Cxt) +import Control.Monad (liftM) +import Data.Comp.Param.Multi.HDitraversable (HDitraversable) +import Data.Comp.Param.Multi.Term +import Data.Comp.Param.Multi.Algebra (appTSigFunM') +import Data.Comp.Param.Multi.Ops ((:+:)(..), (:<:)(..)) + +projn :: Int -> Q [Dec] +projn n = do + let p = mkName $ "proj" ++ show n + let gvars = map (\n -> mkName $ 'g' : show n) [1..n] + let avar = mkName "a" + let bvar = mkName "b" + let ivar = mkName "i" + let xvar = mkName "x" + let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar gvars avar bvar ivar) []]] + sequence $ (sigD p $ genSig gvars avar bvar ivar) : d + where genSig gvars avar bvar ivar = do + let fvar = mkName "f" + let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars + let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a) + (map varT gvars) + let tp' = arrowT `appT` (varT fvar `appT` varT avar `appT` + varT bvar `appT` varT ivar) + `appT` (conT ''Maybe `appT` + (tp `appT` varT avar `appT` + varT bvar `appT` varT ivar)) + forallT (map PlainTV $ fvar : avar : bvar : ivar : gvars) + (sequence cxt) tp' + genDecl x [g] a b i = + [| liftM inj (proj $(varE x) + :: Maybe ($(varT g `appT` varT a `appT` + varT b `appT` varT i))) |] + genDecl x (g:gs) a b i = + [| case (proj $(varE x) + :: Maybe ($(varT g `appT` varT a `appT` + varT b `appT` varT i))) of + Just y -> Just $ inj y + _ -> $(genDecl x gs a b i) |] + genDecl _ _ _ _ _ = error "genDecl called with empty list" + +projectn :: Int -> Q [Dec] +projectn n = do + let p = mkName ("project" ++ show n) + let gvars = map (\n -> mkName $ 'g' : show n) [1..n] + let avar = mkName "a" + let bvar = mkName "b" + let ivar = mkName "i" + let xvar = mkName "x" + let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar n) []]] + sequence $ (sigD p $ genSig gvars avar bvar ivar) : d + where genSig gvars avar bvar ivar = do + let fvar = mkName "f" + let hvar = mkName "h" + let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars + let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a) + (map varT gvars) + let tp' = conT ''Cxt `appT` varT hvar `appT` varT fvar + `appT` varT avar `appT` varT bvar + let tp'' = arrowT `appT` (tp' `appT` varT ivar) + `appT` (conT ''Maybe `appT` + (tp `appT` varT avar `appT` tp' `appT` + varT ivar)) + forallT (map PlainTV $ hvar : fvar : avar : bvar : ivar : gvars) + (sequence cxt) tp'' + genDecl x n = [| case $(varE x) of + Hole _ -> Nothing + Var _ -> Nothing + In t -> $(varE $ mkName $ "proj" ++ show n) t |] + +deepProjectn :: Int -> Q [Dec] +deepProjectn n = do + let p = mkName ("deepProject" ++ show n) + let gvars = map (\n -> mkName $ 'g' : show n) [1..n] + let d = [funD p [clause [] (normalB $ genDecl n) []]] + sequence $ (sigD p $ genSig gvars) : d + where genSig gvars = do + let fvar = mkName "f" + let ivar = mkName "i" + let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars + let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a) + (map varT gvars) + let cxt' = classP ''HDitraversable [tp] + let tp' = arrowT `appT` (conT ''Term `appT` varT fvar `appT` varT ivar) + `appT` (conT ''Maybe `appT` (conT ''Term `appT` tp `appT` varT ivar)) + forallT (map PlainTV $ fvar : ivar : gvars) (sequence $ cxt' : cxt) tp' + genDecl n = [| appTSigFunM' $(varE $ mkName $ "proj" ++ show n) |] diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Show.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Show.hs new file mode 100755 index 0000000..ddc1510 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/Show.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances, + ScopedTypeVariables, UndecidableInstances, KindSignatures #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Derive.Show +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Automatically derive instances of @ShowHD@. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Multi.Derive.Show + ( + ShowHD(..), + makeShowHD + ) where + +import Data.Comp.Derive.Utils +import Data.Comp.Param.Multi.FreshM hiding (Name) +import qualified Data.Comp.Param.Multi.FreshM as FreshM +import Data.Comp.Param.Multi.HDifunctor +import Control.Monad +import Language.Haskell.TH hiding (Cxt, match) +import qualified Data.Traversable as T + +{-| Signature printing. An instance @ShowHD f@ gives rise to an instance + @Show (Term f i)@. -} +class ShowHD f where + showHD :: f FreshM.Name (K (FreshM String)) i -> FreshM String + +newtype Dummy = Dummy String + +instance Show Dummy where + show (Dummy s) = s + +{-| Derive an instance of 'ShowHD' for a type constructor of any parametric + kind taking at least three arguments. -} +makeShowHD :: Name -> Q [Dec] +makeShowHD fname = do + TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname + let args' = init args + -- covariant argument + let coArg :: Name = tyVarBndrName $ last args' + -- contravariant argument + let conArg :: Name = tyVarBndrName $ last $ init args' + let argNames = map (VarT . tyVarBndrName) (init $ init args') + let complType = foldl AppT (ConT name) argNames + let classType = AppT (ConT ''ShowHD) complType + constrs' :: [(Name,[Type])] <- mapM normalConExp constrs + showHDDecl <- funD 'showHD (map (showHDClause conArg coArg) constrs') + let context = map (\arg -> ClassP ''Show [arg]) argNames + return [InstanceD context classType [showHDDecl]] + where showHDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ + showHDClause conArg coArg (constr, args) = do + varXs <- newNames (length args) "x" + -- Pattern for the constructor + let patx = ConP constr $ map VarP varXs + body <- showHDBody (nameBase constr) conArg coArg (zip varXs args) + return $ Clause [patx] (NormalB body) [] + showHDBody :: String -> Name -> Name -> [(Name, Type)] -> ExpQ + showHDBody constr conArg coArg x = + [|liftM (unwords . (constr :) . + map (\x -> if elem ' ' x then "(" ++ x ++ ")" else x)) + (sequence $(listE $ map (showHDB conArg coArg) x))|] + showHDB :: Name -> Name -> (Name, Type) -> ExpQ + showHDB conArg coArg (x, tp) + | not (containsType tp (VarT conArg)) && + not (containsType tp (VarT coArg)) = + [| return $ show $(varE x) |] + | otherwise = + case tp of + AppT (VarT a) _ + | a == coArg -> [| unK $(varE x) |] + AppT (AppT ArrowT (AppT (VarT a) _)) _ + | a == conArg -> + [| withName (\v -> do body <- (unK . $(varE x)) v + return $ "\\" ++ show v ++ " -> " ++ body) |] + SigT tp' _ -> + showHDB conArg coArg (x, tp') + _ -> + if containsType tp (VarT conArg) then + [| showHD $(varE x) |] + else + [| liftM show $ T.mapM (liftM Dummy . unK) $(varE x) |] diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Derive/SmartAConstructors.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/SmartAConstructors.hs new file mode 100755 index 0000000..1ee0d1c --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/SmartAConstructors.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Derive.SmartAConstructors +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Automatically derive smart constructors with annotations for higher-order +-- difunctors. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.Derive.SmartAConstructors + ( + smartAConstructors + ) where + +import Language.Haskell.TH hiding (Cxt) +import Data.Comp.Derive.Utils +import Data.Comp.Param.Multi.Ops +import Data.Comp.Param.Multi.Term +import Data.Comp.Param.Multi.HDifunctor + +import Control.Monad + +{-| Derive smart constructors with annotations for a higher-order difunctor. The + smart constructors are similar to the ordinary constructors, but a + 'injectA . hdimap Var id' is automatically inserted. -} +smartAConstructors :: Name -> Q [Dec] +smartAConstructors fname = do + TyConI (DataD _cxt _tname _targs constrs _deriving) <- abstractNewtypeQ $ reify fname + let cons = map abstractConType constrs + liftM concat $ mapM genSmartConstr cons + where genSmartConstr (name, args) = do + let bname = nameBase name + genSmartConstr' (mkName $ "iA" ++ bname) name args + genSmartConstr' sname name args = do + varNs <- newNames args "x" + varPr <- newName "_p" + let pats = map varP (varPr : varNs) + vars = map varE varNs + val = appE [|injectA $(varE varPr)|] $ + appE [|inj . hdimap Var id|] $ foldl appE (conE name) vars + function = [funD sname [clause pats (normalB [|In $val|]) []]] + sequence function diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Derive/SmartConstructors.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/SmartConstructors.hs new file mode 100755 index 0000000..babf672 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Derive/SmartConstructors.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Derive.SmartConstructors +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- Automatically derive smart constructors for higher-order difunctors. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.Derive.SmartConstructors + ( + smartConstructors + ) where + +import Language.Haskell.TH hiding (Cxt) +import Data.Comp.Derive.Utils +import Data.Comp.Param.Multi.Sum +import Data.Comp.Param.Multi.Term +import Data.Comp.Param.Multi.HDifunctor +import Control.Arrow ((&&&)) +import Control.Monad + +{-| Derive smart constructors for a higher-order difunctor. The smart + constructors are similar to the ordinary constructors, but a + 'inject . hdimap Var id' is automatically inserted. -} +smartConstructors :: Name -> Q [Dec] +smartConstructors fname = do + TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname + let iVar = tyVarBndrName $ last targs + let cons = map (abstractConType &&& iTp iVar) constrs + liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons + where iTp iVar (ForallC _ cxt _) = + -- Check if the GADT phantom type is constrained + case [y | EqualP x y <- cxt, x == VarT iVar] of + [] -> Nothing + tp:_ -> Just tp + iTp _ _ = Nothing + genSmartConstr targs tname ((name, args), miTp) = do + let bname = nameBase name + genSmartConstr' targs tname (mkName $ 'i' : bname) name args miTp + genSmartConstr' targs tname sname name args miTp = do + varNs <- newNames args "x" + let pats = map varP varNs + vars = map varE varNs + val = foldl appE (conE name) vars + sig = genSig targs tname sname args miTp + function = [funD sname [clause pats (normalB [|inject (hdimap Var id $val)|]) []]] + sequence $ sig ++ function + genSig targs tname sname 0 miTp = (:[]) $ do + hvar <- newName "h" + fvar <- newName "f" + avar <- newName "a" + bvar <- newName "b" + ivar <- newName "i" + let targs' = init $ init $ init targs + vars = hvar:fvar:avar:bvar:maybe [ivar] (const []) miTp++targs' + h = varT hvar + f = varT fvar + a = varT avar + b = varT bvar + i = varT ivar + ftype = foldl appT (conT tname) (map varT targs') + constr = classP ''(:<:) [ftype, f] + typ = foldl appT (conT ''Cxt) [h, f, a, b,maybe i return miTp] + typeSig = forallT (map PlainTV vars) (sequence [constr]) typ + sigD sname typeSig + genSig _ _ _ _ _ = [] diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Desugar.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Desugar.hs new file mode 100755 index 0000000..c251b28 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Desugar.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, + UndecidableInstances, OverlappingInstances, TypeOperators, Rank2Types #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Desugar +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This modules defines the 'Desugar' type class for desugaring of terms. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.Desugar where + +import Data.Comp.Param.Multi + +-- |The desugaring term homomorphism. +class (HDifunctor f, HDifunctor g) => Desugar f g where + desugHom :: Hom f g + desugHom = desugHom' . hfmap Hole + desugHom' :: f a (Cxt h g a b) :-> Cxt h g a b + desugHom' x = appCxt (desugHom x) + +-- We make the lifting to sums explicit in order to make the Desugar +-- class work with the default instance declaration further below. +instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where + desugHom = caseHD desugHom desugHom + + +-- |Desugar a term. +desugar :: Desugar f g => Term f :-> Term g +desugar (Term t) = Term (appHom desugHom t) + +-- |Lift desugaring to annotated terms. +desugarA :: (HDifunctor f', HDifunctor g', DistAnn f p f', DistAnn g p g', + Desugar f g) => Term f' :-> Term g' +desugarA (Term t) = Term (appHom (propAnn desugHom) t) + +-- |Default desugaring instance. +instance (HDifunctor f, HDifunctor g, f :<: g) => Desugar f g where + desugHom = simpCxt . inj diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Equality.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Equality.hs new file mode 100755 index 0000000..8884e64 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Equality.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances, + UndecidableInstances, IncoherentInstances, GADTs #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Equality +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines equality for signatures, which lifts to equality for +-- terms. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Multi.Equality + ( + PEq(..), + EqHD(..) + ) where + +import Data.Comp.Param.Multi.Term +import Data.Comp.Param.Multi.Sum +import Data.Comp.Param.Multi.Ops +import Data.Comp.Param.Multi.HDifunctor +import Data.Comp.Param.Multi.FreshM + +-- |Equality on parametric values. The equality test is performed inside the +-- 'FreshM' monad for generating fresh identifiers. +class PEq a where + peq :: a i -> a j -> FreshM Bool + +instance Eq a => PEq (K a) where + peq (K x) (K y) = return $ x == y + +{-| Signature equality. An instance @EqHD f@ gives rise to an instance + @Eq (Term f i)@. The equality test is performed inside the 'FreshM' monad for + generating fresh identifiers. -} +class EqHD f where + eqHD :: PEq a => f Name a i -> f Name a j -> FreshM Bool + +{-| 'EqHD' is propagated through sums. -} +instance (EqHD f, EqHD g) => EqHD (f :+: g) where + eqHD (Inl x) (Inl y) = eqHD x y + eqHD (Inr x) (Inr y) = eqHD x y + eqHD _ _ = return False + +instance PEq Name where + peq x y = return $ nameCoerce x == y + +{-| From an 'EqHD' difunctor an 'Eq' instance of the corresponding term type can + be derived. -} +instance EqHD f => EqHD (Cxt h f) where + eqHD (In e1) (In e2) = eqHD e1 e2 + eqHD (Hole h1) (Hole h2) = peq h1 h2 + eqHD (Var p1) (Var p2) = peq p1 p2 + eqHD _ _ = return False + +instance (EqHD f, PEq a) => PEq (Cxt h f Name a) where + peq = eqHD + +{-| Equality on terms. -} +instance (HDifunctor f, EqHD f) => Eq (Term f i) where + (==) (Term x) (Term y) = evalFreshM $ eqHD x y diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/FreshM.hs b/compdata-param-master/src/Data/Comp/Param/Multi/FreshM.hs new file mode 100755 index 0000000..ffc9f33 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/FreshM.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.FreshM +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines a monad for generating fresh, abstract names, useful +-- e.g. for defining equality on terms. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Multi.FreshM + ( + FreshM, + Name, + withName, + nameCoerce, + evalFreshM + ) where + +import Control.Monad.Reader +import Control.Applicative + +-- |Monad for generating fresh (abstract) names. +newtype FreshM a = FreshM{unFreshM :: Reader Int a} + deriving (Monad, Functor, Applicative) + +-- |Abstract notion of a name (the constructor is hidden). +newtype Name i = Name Int + deriving Eq + +instance Show (Name i) where + show (Name x) = names !! x + where baseNames = ['a'..'z'] + names = map (:[]) baseNames ++ names' 1 + names' n = map (: show n) baseNames ++ names' (n + 1) + +instance Ord (Name i) where + compare (Name x) (Name y) = compare x y + +-- |Change the type tag of a name. +nameCoerce :: Name i -> Name j +nameCoerce (Name x) = Name x + +-- |Run the given computation with the next available name. +withName :: (Name i -> FreshM a) -> FreshM a +withName m = do name <- FreshM (asks Name) + FreshM $ local ((+) 1) $ unFreshM $ m name + +-- |Evaluate a computation that uses fresh names. +evalFreshM :: FreshM a -> a +evalFreshM (FreshM m) = runReader m 0 diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/HDifunctor.hs b/compdata-param-master/src/Data/Comp/Param/Multi/HDifunctor.hs new file mode 100755 index 0000000..553296d --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/HDifunctor.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, Rank2Types, + TypeOperators, GADTs #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.HDifunctor +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines higher-order difunctors, a hybrid between higher-order +-- functors (Johann, Ghani, POPL '08), and difunctors (Meijer, Hutton, FPCA +-- '95). Higher-order difunctors are used to define signatures for +-- compositional parametric generalised data types. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.HDifunctor + ( + HDifunctor (..), + HFunctor (..), + I (..), + K (..), + E (..), + A (..), + (:->), + NatM + ) where + +import Data.Comp.Multi.HFunctor + +-- | This class represents higher-order difunctors. +class HDifunctor f where + hdimap :: (a :-> b) -> (c :-> d) -> f b c :-> f a d + +-- |A higher-order difunctor gives rise to a higher-order functor when +-- restricted to a particular contravariant argument. +instance HDifunctor f => HFunctor (f a) where + hfmap = hdimap id diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/HDitraversable.hs b/compdata-param-master/src/Data/Comp/Param/Multi/HDitraversable.hs new file mode 100755 index 0000000..1ae0c66 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/HDitraversable.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE Rank2Types, FlexibleInstances, MultiParamTypeClasses, + FlexibleContexts, OverlappingInstances, TypeOperators, GADTs #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.HDitraversable +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines traversable higher-order difunctors. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.HDitraversable + ( + HDitraversable (..), + HTraversable (..) + ) where + +import Prelude hiding (mapM, sequence, foldr) +import Data.Comp.Multi.HTraversable +import Data.Comp.Param.Multi.HDifunctor + +{-| HDifunctors representing data structures that can be traversed from left to + right. -} +class HDifunctor f => HDitraversable f where + hdimapM :: Monad m => NatM m b c -> NatM m (f a b) (f a c) diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Ops.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Ops.hs new file mode 100755 index 0000000..04b692f --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Ops.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, UndecidableInstances, IncoherentInstances, + KindSignatures, RankNTypes #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Ops +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module provides operators on higher-order difunctors. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.Ops where + +import Data.Comp.Param.Multi.HDifunctor +import Data.Comp.Param.Multi.HDitraversable +import qualified Data.Comp.Ops as O +import Control.Monad (liftM) + + +-- Sums +infixr 6 :+: + +-- |Formal sum of signatures (difunctors). +data (f :+: g) (a :: * -> *) (b :: * -> *) i = Inl (f a b i) + | Inr (g a b i) + +{-| Utility function to case on a higher-order difunctor sum, without exposing + the internal representation of sums. -} +caseHD :: (f a b i -> c) -> (g a b i -> c) -> (f :+: g) a b i -> c +caseHD f g x = case x of + Inl x -> f x + Inr x -> g x + +instance (HDifunctor f, HDifunctor g) => HDifunctor (f :+: g) where + hdimap f g (Inl e) = Inl (hdimap f g e) + hdimap f g (Inr e) = Inr (hdimap f g e) + +instance (HDitraversable f, HDitraversable g) => HDitraversable (f :+: g) where + hdimapM f (Inl e) = Inl `liftM` hdimapM f e + hdimapM f (Inr e) = Inr `liftM` hdimapM f e + +-- | Signature containment relation for automatic injections. The left-hand must +-- be an atomic signature, where as the right-hand side must have a list-like +-- structure. Examples include @f :<: f :+: g@ and @g :<: f :+: (g :+: h)@, +-- non-examples include @f :+: g :<: f :+: (g :+: h)@ and +-- @f :<: (f :+: g) :+: h@. +class (sub :: (* -> *) -> (* -> *) -> * -> *) :<: sup where + inj :: sub a b :-> sup a b + proj :: NatM Maybe (sup a b) (sub a b) + +instance (:<:) f f where + inj = id + proj = Just + +instance (:<:) f (f :+: g) where + inj = Inl + proj (Inl x) = Just x + proj (Inr _) = Nothing + +instance (f :<: g) => (:<:) f (h :+: g) where + inj = Inr . inj + proj (Inr x) = proj x + proj (Inl _) = Nothing + + +-- Products +infixr 8 :*: + +-- |Formal product of signatures (higher-order difunctors). +data (f :*: g) a b = f a b :*: g a b + +ffst :: (f :*: g) a b -> f a b +ffst (x :*: _) = x + +fsnd :: (f :*: g) a b -> g a b +fsnd (_ :*: x) = x + + +-- Constant Products +infixr 7 :&: + +{-| This data type adds a constant product to a signature. -} +data (f :&: p) (a :: * -> *) (b :: * -> *) i = f a b i :&: p + +instance HDifunctor f => HDifunctor (f :&: p) where + hdimap f g (v :&: c) = hdimap f g v :&: c + +instance HDitraversable f => HDitraversable (f :&: p) where + hdimapM f (v :&: c) = liftM (:&: c) (hdimapM f v) + +{-| This class defines how to distribute an annotation over a sum of + signatures. -} +class DistAnn (s :: (* -> *) -> (* -> *) -> * -> *) p s' | s' -> s, s' -> p where + {-| Inject an annotation over a signature. -} + injectA :: p -> s a b :-> s' a b + {-| Project an annotation from a signature. -} + projectA :: s' a b :-> (s a b O.:&: p) + +class RemA (s :: (* -> *) -> (* -> *) -> * -> *) s' | s -> s' where + {-| Remove annotations from a signature. -} + remA :: s a b :-> s' a b + +instance (RemA s s') => RemA (f :&: p :+: s) (f :+: s') where + remA (Inl (v :&: _)) = Inl v + remA (Inr v) = Inr $ remA v + +instance RemA (f :&: p) f where + remA (v :&: _) = v + +instance DistAnn f p (f :&: p) where + injectA c v = v :&: c + + projectA (v :&: p) = v O.:&: p + +instance (DistAnn s p s') => DistAnn (f :+: s) p ((f :&: p) :+: s') where + injectA c (Inl v) = Inl (v :&: c) + injectA c (Inr v) = Inr $ injectA c v + + projectA (Inl (v :&: p)) = Inl v O.:&: p + projectA (Inr v) = let (v' O.:&: p) = projectA v + in Inr v' O.:&: p diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Ordering.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Ordering.hs new file mode 100755 index 0000000..54fc5aa --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Ordering.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances, + UndecidableInstances, IncoherentInstances, GADTs #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Ordering +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines ordering of signatures, which lifts to ordering of +-- terms and contexts. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Multi.Ordering + ( + POrd(..), + OrdHD(..) + ) where + +import Data.Comp.Param.Multi.Term +import Data.Comp.Param.Multi.Sum +import Data.Comp.Param.Multi.Ops +import Data.Comp.Param.Multi.HDifunctor +import Data.Comp.Param.Multi.FreshM +import Data.Comp.Param.Multi.Equality + +-- |Ordering of parametric values. +class PEq a => POrd a where + pcompare :: a i -> a j -> FreshM Ordering + +instance Ord a => POrd (K a) where + pcompare (K x) (K y) = return $ compare x y + +{-| Signature ordering. An instance @OrdHD f@ gives rise to an instance + @Ord (Term f)@. -} +class EqHD f => OrdHD f where + compareHD :: POrd a => f Name a i -> f Name a j -> FreshM Ordering + +{-| 'OrdHD' is propagated through sums. -} +instance (OrdHD f, OrdHD g) => OrdHD (f :+: g) where + compareHD (Inl x) (Inl y) = compareHD x y + compareHD (Inl _) (Inr _) = return LT + compareHD (Inr x) (Inr y) = compareHD x y + compareHD (Inr _) (Inl _) = return GT + +{-| From an 'OrdHD' difunctor an 'Ord' instance of the corresponding term type + can be derived. -} +instance OrdHD f => OrdHD (Cxt h f) where + compareHD (In e1) (In e2) = compareHD e1 e2 + compareHD (Hole h1) (Hole h2) = pcompare h1 h2 + compareHD (Var p1) (Var p2) = pcompare p1 p2 + compareHD (In _) _ = return LT + compareHD (Hole _) (In _) = return GT + compareHD (Hole _) (Var _) = return LT + compareHD (Var _) _ = return GT + +instance POrd Name where + pcompare x y = return $ compare (nameCoerce x) y + +instance (OrdHD f, POrd a) => POrd (Cxt h f Name a) where + pcompare = compareHD + +{-| Ordering of terms. -} +instance (HDifunctor f, OrdHD f) => Ord (Term f i) where + compare (Term x) (Term y) = evalFreshM $ compareHD x y diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Show.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Show.hs new file mode 100755 index 0000000..49d786c --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Show.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TypeOperators, FlexibleInstances, TypeSynonymInstances, + IncoherentInstances, UndecidableInstances, TemplateHaskell, GADTs #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Show +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines showing of signatures, which lifts to showing of terms. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Multi.Show + ( + ShowHD(..) + ) where + +import Data.Comp.Param.Multi.Term +import Data.Comp.Param.Multi.HDifunctor +import Data.Comp.Param.Multi.Ops +import Data.Comp.Param.Multi.Derive +import Data.Comp.Param.Multi.FreshM + +-- Lift ShowHD to sums +$(derive [liftSum] [''ShowHD]) + +{-| From an 'ShowHD' higher-order difunctor an 'ShowHD' instance of the + corresponding term type can be derived. -} +instance (HDifunctor f, ShowHD f) => ShowHD (Cxt h f) where + showHD (In t) = showHD $ hfmap (K . showHD) t + showHD (Hole h) = unK h + showHD (Var p) = return $ show p + +{-| Printing of terms. -} +instance (HDifunctor f, ShowHD f) => Show (Term f i) where + show = evalFreshM . showHD . toCxt . unTerm + +instance (ShowHD f, Show p) => ShowHD (f :&: p) where + showHD (x :&: p) = do sx <- showHD x + return $ sx ++ " :&: " ++ show p diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Sum.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Sum.hs new file mode 100755 index 0000000..e46afe0 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Sum.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances, + FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances, + ScopedTypeVariables, TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Sum +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module provides the infrastructure to extend signatures. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.Sum + ( + (:<:), + (:+:), + caseHD, + + -- * Projections for Signatures and Terms + proj, + proj2, + proj3, + proj4, + proj5, + proj6, + proj7, + proj8, + proj9, + proj10, + project, + project2, + project3, + project4, + project5, + project6, + project7, + project8, + project9, + project10, + deepProject, + deepProject2, + deepProject3, + deepProject4, + deepProject5, + deepProject6, + deepProject7, + deepProject8, + deepProject9, + deepProject10, + + -- * Injections for Signatures and Terms + inj, + inj2, + inj3, + inj4, + inj5, + inj6, + inj7, + inj8, + inj9, + inj10, + inject, + inject2, + inject3, + inject4, + inject5, + inject6, + inject7, + inject8, + inject9, + inject10, + deepInject, + deepInject2, + deepInject3, + deepInject4, + deepInject5, + deepInject6, + deepInject7, + deepInject8, + deepInject9, + deepInject10, + + injectCxt, + liftCxt + ) where + +import Prelude hiding (sequence) +import Control.Monad hiding (sequence) +import Data.Comp.Param.Multi.Term +import Data.Comp.Param.Multi.Algebra +import Data.Comp.Param.Multi.Ops +import Data.Comp.Param.Multi.Derive.Projections +import Data.Comp.Param.Multi.Derive.Injections +import Data.Comp.Param.Multi.HDifunctor +import Data.Comp.Param.Multi.HDitraversable + +$(liftM concat $ mapM projn [2..10]) + +-- |Project the outermost layer of a term to a sub signature. If the signature +-- @g@ is compound of /n/ atomic signatures, use @project@/n/ instead. +project :: (g :<: f) => NatM Maybe (Cxt h f a b) (g a (Cxt h f a b)) +project (In t) = proj t +project (Hole _) = Nothing +project (Var _) = Nothing + +$(liftM concat $ mapM projectn [2..10]) + +-- | Tries to coerce a term/context to a term/context over a sub-signature. If +-- the signature @g@ is compound of /n/ atomic signatures, use +-- @deepProject@/n/ instead. +deepProject :: (HDitraversable g, g :<: f) => Term f i -> Maybe (Term g i) +{-# INLINE deepProject #-} +deepProject = appTSigFunM' proj + +$(liftM concat $ mapM deepProjectn [2..10]) +{-# INLINE deepProject2 #-} +{-# INLINE deepProject3 #-} +{-# INLINE deepProject4 #-} +{-# INLINE deepProject5 #-} +{-# INLINE deepProject6 #-} +{-# INLINE deepProject7 #-} +{-# INLINE deepProject8 #-} +{-# INLINE deepProject9 #-} +{-# INLINE deepProject10 #-} + +$(liftM concat $ mapM injn [2..10]) + +-- |Inject a term where the outermost layer is a sub signature. If the signature +-- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead. +inject :: (g :<: f) => g a (Cxt h f a b) :-> Cxt h f a b +inject = In . inj + +$(liftM concat $ mapM injectn [2..10]) + +-- |Inject a term over a sub signature to a term over larger signature. If the +-- signature @g@ is compound of /n/ atomic signatures, use @deepInject@/n/ +-- instead. +deepInject :: (HDifunctor g, g :<: f) => CxtFun g f +{-# INLINE deepInject #-} +deepInject = appSigFun inj + +$(liftM concat $ mapM deepInjectn [2..10]) +{-# INLINE deepInject2 #-} +{-# INLINE deepInject3 #-} +{-# INLINE deepInject4 #-} +{-# INLINE deepInject5 #-} +{-# INLINE deepInject6 #-} +{-# INLINE deepInject7 #-} +{-# INLINE deepInject8 #-} +{-# INLINE deepInject9 #-} +{-# INLINE deepInject10 #-} + +{-| This function injects a whole context into another context. -} +injectCxt :: (HDifunctor g, g :<: f) => Cxt h g a (Cxt h f a b) :-> Cxt h f a b +injectCxt (In t) = inject $ hfmap injectCxt t +injectCxt (Hole x) = x +injectCxt (Var p) = Var p + +{-| This function lifts the given functor to a context. -} +liftCxt :: (HDifunctor f, g :<: f) => g a b :-> Cxt Hole f a b +liftCxt g = simpCxt $ inj g + +instance (Show (f a b i), Show (g a b i)) => Show ((f :+: g) a b i) where + show (Inl v) = show v + show (Inr v) = show v + +instance (Ord (f a b i), Ord (g a b i)) => Ord ((f :+: g) a b i) where + compare (Inl _) (Inr _) = LT + compare (Inr _) (Inl _) = GT + compare (Inl x) (Inl y) = compare x y + compare (Inr x) (Inr y) = compare x y + +instance (Eq (f a b i), Eq (g a b i)) => Eq ((f :+: g) a b i) where + (Inl x) == (Inl y) = x == y + (Inr x) == (Inr y) = x == y + _ == _ = False diff --git a/compdata-param-master/src/Data/Comp/Param/Multi/Term.hs b/compdata-param-master/src/Data/Comp/Param/Multi/Term.hs new file mode 100755 index 0000000..9bde754 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Multi/Term.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE EmptyDataDecls, GADTs, KindSignatures, Rank2Types, + MultiParamTypeClasses, TypeOperators, ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Multi.Term +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines the central notion of /generalised parametrised terms/ +-- and their generalisation to generalised parametrised contexts. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Multi.Term + ( + Cxt(..), + Hole, + NoHole, + Term(..), + Trm, + Context, + simpCxt, + toCxt, + hfmapCxt, + hdimapMCxt, + ParamFunctor (..) + ) where + +import Prelude hiding (mapM, sequence, foldl, foldl1, foldr, foldr1) +import Data.Comp.Param.Multi.HDifunctor +import Data.Comp.Param.Multi.HDitraversable +import Control.Monad +import Unsafe.Coerce +import Data.Maybe (fromJust) + +{-| This data type represents contexts over a signature. Contexts are terms + containing zero or more holes, and zero or more parameters. The first + parameter is a phantom type indicating whether the context has holes. The + second paramater is the signature of the context, in the form of a + "Data.Comp.Param.Multi.HDifunctor". The third parameter is the type of + parameters, the fourth parameter is the type of holes, and the fifth + parameter is the GADT type. -} +data Cxt :: * -> ((* -> *) -> (* -> *) -> * -> *) -> (* -> *) -> (* -> *) -> * -> * where + In :: f a (Cxt h f a b) i -> Cxt h f a b i + Hole :: b i -> Cxt Hole f a b i + Var :: a i -> Cxt h f a b i + +{-| Phantom type used to define 'Context'. -} +data Hole + +{-| Phantom type used to define 'Term'. -} +data NoHole + +{-| A context may contain holes. -} +type Context = Cxt Hole + +{-| \"Preterms\" |-} +type Trm f a = Cxt NoHole f a (K ()) + +{-| A term is a context with no holes, where all occurrences of the + contravariant parameter is fully parametric. -} +newtype Term f i = Term{unTerm :: forall a. Trm f a i} + +{-| Convert a difunctorial value into a context. -} +simpCxt :: HDifunctor f => f a b :-> Cxt Hole f a b +{-# INLINE simpCxt #-} +simpCxt = In . hfmap Hole + +toCxt :: HDifunctor f => Trm f a :-> Cxt h f a b +{-# INLINE toCxt #-} +toCxt = unsafeCoerce + +-- | This is an instance of 'hfmap' for 'Cxt'. +hfmapCxt :: forall h f a b b'. HDifunctor f + => (b :-> b') -> Cxt h f a b :-> Cxt h f a b' +hfmapCxt f = run + where run :: Cxt h f a b :-> Cxt h f a b' + run (In t) = In $ hfmap run t + run (Var a) = Var a + run (Hole b) = Hole $ f b + +-- | This is an instance of 'hdimapM' for 'Cxt'. +hdimapMCxt :: forall h f a b b' m . (HDitraversable f, Monad m) + => NatM m b b' -> NatM m (Cxt h f a b) (Cxt h f a b') +hdimapMCxt f = run + where run :: NatM m (Cxt h f a b) (Cxt h f a b') + run (In t) = liftM In $ hdimapM run t + run (Var a) = return $ Var a + run (Hole b) = liftM Hole (f b) + + + +{-| Monads for which embedded @Trm@ values, which are parametric at top level, + can be made into monadic @Term@ values, i.e. \"pushing the parametricity + inwards\". -} +class ParamFunctor m where + termM :: (forall a. m (Trm f a i)) -> m (Term f i) + +coerceTermM :: ParamFunctor m => (forall a. m (Trm f a i)) -> m (Term f i) +{-# INLINE coerceTermM #-} +coerceTermM t = unsafeCoerce t + +{-# RULES + "termM/coerce'" termM = coerceTermM + #-} + +instance ParamFunctor Maybe where + {-# NOINLINE [1] termM #-} + termM Nothing = Nothing + termM x = Just (Term $ fromJust x) + +instance ParamFunctor (Either a) where + {-# NOINLINE [1] termM #-} + termM (Left x) = Left x + termM x = Right (Term $ fromRight x) + where fromRight :: Either a b -> b + fromRight (Right x) = x + fromRight _ = error "fromRight: Left" + +instance ParamFunctor [] where + {-# NOINLINE [1] termM #-} + termM [] = [] + termM l = Term (head l) : termM (tail l) diff --git a/compdata-param-master/src/Data/Comp/Param/Ops.hs b/compdata-param-master/src/Data/Comp/Param/Ops.hs new file mode 100755 index 0000000..0f6cd3b --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Ops.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, UndecidableInstances, IncoherentInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Ops +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module provides operators on difunctors. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Ops where + +import Data.Comp.Param.Difunctor +import Data.Comp.Param.Ditraversable +import Control.Monad (liftM) + + +-- Sums +infixr 6 :+: + +-- |Formal sum of signatures (difunctors). +data (f :+: g) a b = Inl (f a b) + | Inr (g a b) + +{-| Utility function to case on a difunctor sum, without exposing the internal + representation of sums. -} +caseD :: (f a b -> c) -> (g a b -> c) -> (f :+: g) a b -> c +caseD f g x = case x of + Inl x -> f x + Inr x -> g x + +instance (Difunctor f, Difunctor g) => Difunctor (f :+: g) where + dimap f g (Inl e) = Inl (dimap f g e) + dimap f g (Inr e) = Inr (dimap f g e) + +instance (Ditraversable f, Ditraversable g) => Ditraversable (f :+: g) where + dimapM f (Inl e) = Inl `liftM` dimapM f e + dimapM f (Inr e) = Inr `liftM` dimapM f e + disequence (Inl e) = Inl `liftM` disequence e + disequence (Inr e) = Inr `liftM` disequence e + +-- | Signature containment relation for automatic injections. The left-hand must +-- be an atomic signature, where as the right-hand side must have a list-like +-- structure. Examples include @f :<: f :+: g@ and @g :<: f :+: (g :+: h)@, +-- non-examples include @f :+: g :<: f :+: (g :+: h)@ and +-- @f :<: (f :+: g) :+: h@. +class sub :<: sup where + inj :: sub a b -> sup a b + proj :: sup a b -> Maybe (sub a b) + +instance (:<:) f f where + inj = id + proj = Just + +instance (:<:) f (f :+: g) where + inj = Inl + proj (Inl x) = Just x + proj (Inr _) = Nothing + +instance (f :<: g) => (:<:) f (h :+: g) where + inj = Inr . inj + proj (Inr x) = proj x + proj (Inl _) = Nothing + + +-- Products +infixr 8 :*: + +-- |Formal product of signatures (difunctors). +data (f :*: g) a b = f a b :*: g a b + +ffst :: (f :*: g) a b -> f a b +ffst (x :*: _) = x + +fsnd :: (f :*: g) a b -> g a b +fsnd (_ :*: x) = x + + +-- Constant Products +infixr 7 :&: + +{-| This data type adds a constant product to a signature. -} +data (f :&: p) a b = f a b :&: p + +instance Difunctor f => Difunctor (f :&: p) where + dimap f g (v :&: c) = dimap f g v :&: c + +instance Ditraversable f => Ditraversable (f :&: p) where + dimapM f (v :&: c) = liftM (:&: c) (dimapM f v) + disequence (v :&: c) = liftM (:&: c) (disequence v) + +{-| This class defines how to distribute an annotation over a sum of + signatures. -} +class DistAnn s p s' | s' -> s, s' -> p where + {-| Inject an annotation over a signature. -} + injectA :: p -> s a b -> s' a b + {-| Project an annotation from a signature. -} + projectA :: s' a b -> (s a b, p) + +class RemA s s' | s -> s' where + {-| Remove annotations from a signature. -} + remA :: s a b -> s' a b + +instance (RemA s s') => RemA (f :&: p :+: s) (f :+: s') where + remA (Inl (v :&: _)) = Inl v + remA (Inr v) = Inr $ remA v + +instance RemA (f :&: p) f where + remA (v :&: _) = v + +instance DistAnn f p (f :&: p) where + injectA c v = v :&: c + + projectA (v :&: p) = (v,p) + +instance (DistAnn s p s') => DistAnn (f :+: s) p ((f :&: p) :+: s') where + injectA c (Inl v) = Inl (v :&: c) + injectA c (Inr v) = Inr $ injectA c v + + projectA (Inl (v :&: p)) = (Inl v,p) + projectA (Inr v) = let (v',p) = projectA v + in (Inr v',p) \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Ordering.hs b/compdata-param-master/src/Data/Comp/Param/Ordering.hs new file mode 100755 index 0000000..c179be7 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Ordering.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances, + UndecidableInstances, IncoherentInstances, GADTs #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Ordering +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines ordering of signatures, which lifts to ordering of +-- terms and contexts. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Ordering + ( + POrd(..), + OrdD(..), + compList + ) where + +import Data.Comp.Param.Term +import Data.Comp.Param.Sum +import Data.Comp.Param.Ops +import Data.Comp.Param.Difunctor +import Data.Comp.Param.FreshM +import Data.Comp.Param.Equality +import Data.Maybe (fromMaybe) +import Data.List (find) +import Control.Monad (liftM) + +-- |Ordering of parametric values. +class PEq a => POrd a where + pcompare :: a -> a -> FreshM Ordering + +instance POrd a => POrd [a] where + pcompare l1 l2 + | length l1 < length l2 = return LT + | length l1 > length l2 = return GT + | otherwise = liftM compList $ mapM (uncurry pcompare) $ zip l1 l2 + +compList :: [Ordering] -> Ordering +compList = fromMaybe EQ . find (/= EQ) + +instance Ord a => POrd a where + pcompare x y = return $ compare x y + +{-| Signature ordering. An instance @OrdD f@ gives rise to an instance + @Ord (Term f)@. -} +class EqD f => OrdD f where + compareD :: POrd a => f Name a -> f Name a -> FreshM Ordering + +{-| 'OrdD' is propagated through sums. -} +instance (OrdD f, OrdD g) => OrdD (f :+: g) where + compareD (Inl x) (Inl y) = compareD x y + compareD (Inl _) (Inr _) = return LT + compareD (Inr x) (Inr y) = compareD x y + compareD (Inr _) (Inl _) = return GT + +{-| From an 'OrdD' difunctor an 'Ord' instance of the corresponding term type + can be derived. -} +instance OrdD f => OrdD (Cxt h f) where + compareD (In e1) (In e2) = compareD e1 e2 + compareD (Hole h1) (Hole h2) = pcompare h1 h2 + compareD (Var p1) (Var p2) = pcompare p1 p2 + compareD (In _) _ = return LT + compareD (Hole _) (In _) = return GT + compareD (Hole _) (Var _) = return LT + compareD (Var _) _ = return GT + +instance (OrdD f, POrd a) => POrd (Cxt h f Name a) where + pcompare = compareD + +{-| Ordering of terms. -} +instance (Difunctor f, OrdD f) => Ord (Term f) where + compare (Term x) (Term y) = evalFreshM $ compareD x y \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Show.hs b/compdata-param-master/src/Data/Comp/Param/Show.hs new file mode 100755 index 0000000..b5d5cdc --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Show.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TypeOperators, FlexibleInstances, TypeSynonymInstances, + IncoherentInstances, UndecidableInstances, TemplateHaskell, GADTs #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Show +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines showing of signatures, which lifts to showing of terms. +-- +-------------------------------------------------------------------------------- +module Data.Comp.Param.Show + ( + ShowD(..) + ) where + +import Data.Comp.Param.Term +import Data.Comp.Param.Ops +import Data.Comp.Param.Derive +import Data.Comp.Param.FreshM + +-- Lift ShowD to sums +$(derive [liftSum] [''ShowD]) + +{-| From an 'ShowD' difunctor an 'ShowD' instance of the corresponding term type + can be derived. -} +instance (Difunctor f, ShowD f) => ShowD (Cxt h f) where + showD (In t) = showD $ fmap showD t + showD (Hole h) = h + showD (Var p) = return $ show p + +{-| Printing of terms. -} +instance (Difunctor f, ShowD f) => Show (Term f) where + show = evalFreshM . showD . toCxt . unTerm + +instance (ShowD f, Show p) => ShowD (f :&: p) where + showD (x :&: p) = do sx <- showD x + return $ sx ++ " :&: " ++ show p \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Sum.hs b/compdata-param-master/src/Data/Comp/Param/Sum.hs new file mode 100755 index 0000000..b6fbfa9 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Sum.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances, + FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances, + ScopedTypeVariables, TemplateHaskell, Rank2Types #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Sum +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module provides the infrastructure to extend signatures. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Sum + ( + (:<:), + (:+:), + caseD, + + -- * Projections for Signatures and Terms + proj, + proj2, + proj3, + proj4, + proj5, + proj6, + proj7, + proj8, + proj9, + proj10, + project, + project2, + project3, + project4, + project5, + project6, + project7, + project8, + project9, + project10, + deepProject, + deepProject2, + deepProject3, + deepProject4, + deepProject5, + deepProject6, + deepProject7, + deepProject8, + deepProject9, + deepProject10, + + -- * Injections for Signatures and Terms + inj, + inj2, + inj3, + inj4, + inj5, + inj6, + inj7, + inj8, + inj9, + inj10, + inject, + inject', + inject2, + inject3, + inject4, + inject5, + inject6, + inject7, + inject8, + inject9, + inject10, + deepInject, + deepInject2, + deepInject3, + deepInject4, + deepInject5, + deepInject6, + deepInject7, + deepInject8, + deepInject9, + deepInject10, + + injectCxt, + liftCxt + ) where + +import Prelude hiding (sequence) +import Control.Monad hiding (sequence) +import Data.Comp.Param.Term +import Data.Comp.Param.Algebra +import Data.Comp.Param.Ops +import Data.Comp.Param.Derive.Projections +import Data.Comp.Param.Derive.Injections +import Data.Comp.Param.Difunctor +import Data.Comp.Param.Ditraversable + +$(liftM concat $ mapM projn [2..10]) + +-- |Project the outermost layer of a term to a sub signature. If the signature +-- @g@ is compound of /n/ atomic signatures, use @project@/n/ instead. +project :: (g :<: f) => Cxt h f a b -> Maybe (g a (Cxt h f a b)) +project (In t) = proj t +project (Hole _) = Nothing +project (Var _) = Nothing + +$(liftM concat $ mapM projectn [2..10]) + +-- | Tries to coerce a term/context to a term/context over a sub-signature. If +-- the signature @g@ is compound of /n/ atomic signatures, use +-- @deepProject@/n/ instead. +deepProject :: (Ditraversable g, g :<: f) => Term f -> Maybe (Term g) +{-# INLINE deepProject #-} +deepProject = appTSigFunM' proj + +$(liftM concat $ mapM deepProjectn [2..10]) +{-# INLINE deepProject2 #-} +{-# INLINE deepProject3 #-} +{-# INLINE deepProject4 #-} +{-# INLINE deepProject5 #-} +{-# INLINE deepProject6 #-} +{-# INLINE deepProject7 #-} +{-# INLINE deepProject8 #-} +{-# INLINE deepProject9 #-} +{-# INLINE deepProject10 #-} + +$(liftM concat $ mapM injn [2..10]) + +-- |Inject a term where the outermost layer is a sub signature. If the signature +-- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead. +inject :: (g :<: f) => g a (Cxt h f a b) -> Cxt h f a b +inject = In . inj + +-- |Inject a term where the outermost layer is a sub signature. If the signature +-- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead. +inject' :: (Difunctor g, g :<: f) => g (Cxt h f a b) (Cxt h f a b) -> Cxt h f a b +inject' = inject . dimap Var id + +$(liftM concat $ mapM injectn [2..10]) + +-- |Inject a term over a sub signature to a term over larger signature. If the +-- signature @g@ is compound of /n/ atomic signatures, use @deepInject@/n/ +-- instead. +deepInject :: (Difunctor g, g :<: f) => Term g -> Term f +{-# INLINE deepInject #-} +deepInject (Term t) = Term (appSigFun inj t) + +$(liftM concat $ mapM deepInjectn [2..10]) +{-# INLINE deepInject2 #-} +{-# INLINE deepInject3 #-} +{-# INLINE deepInject4 #-} +{-# INLINE deepInject5 #-} +{-# INLINE deepInject6 #-} +{-# INLINE deepInject7 #-} +{-# INLINE deepInject8 #-} +{-# INLINE deepInject9 #-} +{-# INLINE deepInject10 #-} + +{-| This function injects a whole context into another context. -} +injectCxt :: (Difunctor g, g :<: f) => Cxt h g a (Cxt h f a b) -> Cxt h f a b +injectCxt (In t) = inject $ difmap injectCxt t +injectCxt (Hole x) = x +injectCxt (Var p) = Var p + +{-| This function lifts the given functor to a context. -} +liftCxt :: (Difunctor f, g :<: f) => g a b -> Cxt Hole f a b +liftCxt g = simpCxt $ inj g + +instance (Show (f a b), Show (g a b)) => Show ((f :+: g) a b) where + show (Inl v) = show v + show (Inr v) = show v + +instance (Ord (f a b), Ord (g a b)) => Ord ((f :+: g) a b) where + compare (Inl _) (Inr _) = LT + compare (Inr _) (Inl _) = GT + compare (Inl x) (Inl y) = compare x y + compare (Inr x) (Inr y) = compare x y + +instance (Eq (f a b), Eq (g a b)) => Eq ((f :+: g) a b) where + (Inl x) == (Inl y) = x == y + (Inr x) == (Inr y) = x == y + _ == _ = False \ No newline at end of file diff --git a/compdata-param-master/src/Data/Comp/Param/Term.hs b/compdata-param-master/src/Data/Comp/Param/Term.hs new file mode 100755 index 0000000..33df646 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Term.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE EmptyDataDecls, GADTs, KindSignatures, Rank2Types, + MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Term +-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved +-- License : BSD3 +-- Maintainer : Tom Hvitved +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This module defines the central notion of /parametrised terms/ and their +-- generalisation to parametrised contexts. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Term + ( + Cxt(..), + Hole, + NoHole, + Term(..), + Trm, + Context, + simpCxt, + toCxt, + cxtMap, + ParamFunctor(..) + ) where + +import Prelude hiding (mapM, sequence, foldl, foldl1, foldr, foldr1) +import Data.Comp.Param.Difunctor +import Unsafe.Coerce (unsafeCoerce) + +import Data.Maybe (fromJust) + +{-| This data type represents contexts over a signature. Contexts are terms + containing zero or more holes, and zero or more parameters. The first + parameter is a phantom type indicating whether the context has holes. The + second paramater is the signature of the context, in the form of a + "Data.Comp.Param.Difunctor". The third parameter is the type of parameters, + and the fourth parameter is the type of holes. -} +data Cxt :: * -> (* -> * -> *) -> * -> * -> * where + In :: f a (Cxt h f a b) -> Cxt h f a b + Hole :: b -> Cxt Hole f a b + Var :: a -> Cxt h f a b + +{-| Phantom type used to define 'Context'. -} +data Hole + +{-| Phantom type used to define 'Term'. -} +data NoHole + +{-| A context may contain holes. -} +type Context = Cxt Hole + +{-| \"Preterms\" -} +type Trm f a = Cxt NoHole f a () + +{-| A term is a context with no holes, where all occurrences of the + contravariant parameter is fully parametric. -} +newtype Term f = Term{unTerm :: forall a. Trm f a} + +{-| Convert a difunctorial value into a context. -} +simpCxt :: Difunctor f => f a b -> Cxt Hole f a b +{-# INLINE simpCxt #-} +simpCxt = In . difmap Hole + +toCxt :: Difunctor f => Trm f a -> Cxt h f a b +{-# INLINE toCxt #-} +toCxt = unsafeCoerce + +-- | This combinator maps a function over a context by applying the +-- function to each hole. +cxtMap :: Difunctor f => (b -> c) -> Context f a b -> Context f a c +cxtMap f (Hole x) = Hole (f x) +cxtMap _ (Var x) = Var x +cxtMap f (In t) = In (dimap id (cxtMap f) t) + +-- Param Functor + +{-| Monads for which embedded @Trm@ values, which are parametric at top level, + can be made into monadic @Term@ values, i.e. \"pushing the parametricity + inwards\". -} +class ParamFunctor m where + termM :: (forall a. m (Trm f a)) -> m (Term f) + +coerceTermM :: ParamFunctor m => (forall a. m (Trm f a)) -> m (Term f) +{-# INLINE coerceTermM #-} +coerceTermM t = unsafeCoerce t + +{-# RULES + "termM/coerce" termM = coerceTermM + #-} + +instance ParamFunctor Maybe where + {-# NOINLINE [1] termM #-} + termM Nothing = Nothing + termM x = Just (Term $ fromJust x) + +instance ParamFunctor (Either a) where + {-# NOINLINE [1] termM #-} + termM (Left x) = Left x + termM x = Right (Term $ fromRight x) + where fromRight :: Either a b -> b + fromRight (Right x) = x + fromRight _ = error "fromRight: Left" + +instance ParamFunctor [] where + {-# NOINLINE [1] termM #-} + termM [] = [] + termM l = Term (head l) : termM (tail l) diff --git a/compdata-param-master/src/Data/Comp/Param/Thunk.hs b/compdata-param-master/src/Data/Comp/Param/Thunk.hs new file mode 100755 index 0000000..b578240 --- /dev/null +++ b/compdata-param-master/src/Data/Comp/Param/Thunk.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE TypeOperators, FlexibleContexts, Rank2Types, GADTs #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Comp.Param.Thunk +-- Copyright : (c) 2011 Patrick Bahr +-- License : BSD3 +-- Maintainer : Patrick Bahr +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) +-- +-- This modules defines terms & contexts with thunks, with deferred +-- monadic computations. +-- +-------------------------------------------------------------------------------- + +module Data.Comp.Param.Thunk + (TermT + ,TrmT + ,CxtT + ,Thunk + ,thunk + ,whnf + ,whnf' + ,whnfPr + ,nf + ,nfT + ,nfPr + ,nfTPr + ,evalStrict + ,AlgT + ,strict + ,strict') + where + +import Data.Comp.Param.Term +import Data.Comp.Param.Sum +import Data.Comp.Param.Ops +import Data.Comp.Param.Algebra +import Data.Comp.Param.Ditraversable +import Data.Comp.Param.Difunctor + +import Control.Monad + +-- | This type represents terms with thunks. +type TermT m f = Term (Thunk m :+: f) + +-- | This type represents terms with thunks. +type TrmT m f a = Trm (Thunk m :+: f) a + +-- | This type represents contexts with thunks. +type CxtT h m f a = Cxt h (Thunk m :+: f) a + +newtype Thunk m a b = Thunk (m b) + +-- | This function turns a monadic computation into a thunk. +thunk :: (Thunk m :<: f) => m (Cxt h f a b) -> Cxt h f a b +thunk = inject . Thunk + +-- | This function evaluates all thunks until a non-thunk node is +-- found. +whnf :: Monad m => TrmT m f a -> m (Either a (f a (TrmT m f a))) +whnf (In (Inl (Thunk m))) = m >>= whnf +whnf (In (Inr t)) = return $ Right t +whnf (Var x) = return $ Left x + +whnf' :: Monad m => TrmT m f a -> m (TrmT m f a) +whnf' = liftM (either Var inject) . whnf + +-- | This function first evaluates the argument term into whnf via +-- 'whnf' and then projects the top-level signature to the desired +-- subsignature. Failure to do the projection is signalled as a +-- failure in the monad. +whnfPr :: (Monad m, g :<: f) => TrmT m f a -> m (g a (TrmT m f a)) +whnfPr t = do res <- whnf t + case res of + Left _ -> fail "cannot project variable" + Right t -> + case proj t of + Just res' -> return res' + Nothing -> fail "projection failed" + + +-- | This function evaluates all thunks. +nfT :: (ParamFunctor m, Monad m, Ditraversable f) => TermT m f -> m (Term f) +nfT t = termM $ nf $ unTerm t + +-- | This function evaluates all thunks. +nf :: (Monad m, Ditraversable f) => TrmT m f a -> m (Trm f a) +nf = either (return . Var) (liftM In . dimapM nf) <=< whnf + +-- | This function evaluates all thunks while simultaneously +-- projecting the term to a smaller signature. Failure to do the +-- projection is signalled as a failure in the monad as in 'whnfPr'. +nfTPr :: (ParamFunctor m, Monad m, Ditraversable g, g :<: f) => TermT m f -> m (Term g) +nfTPr t = termM $ nfPr $ unTerm t + +-- | This function evaluates all thunks while simultaneously +-- projecting the term to a smaller signature. Failure to do the +-- projection is signalled as a failure in the monad as in 'whnfPr'. +nfPr :: (Monad m, Ditraversable g, g :<: f) => TrmT m f a -> m (Trm g a) +nfPr = liftM In . dimapM nfPr <=< whnfPr + + +evalStrict :: (Ditraversable g, Monad m, g :<: f) => + (g (TrmT m f a) (f a (TrmT m f a)) -> TrmT m f a) + -> g (TrmT m f a) (TrmT m f a) -> TrmT m f a +evalStrict cont t = thunk $ do + t' <- dimapM (liftM (either (const Nothing) Just) . whnf) t + case disequence t' of + Nothing -> return $ inject' t + Just s -> return $ cont s + + +-- | This type represents algebras which have terms with thunks as +-- carrier. +type AlgT m f g = Alg f (TermT m g) + +-- | This combinator makes the evaluation of the given functor +-- application strict by evaluating all thunks of immediate subterms. +strict :: (f :<: g, Ditraversable f, Monad m) => f a (TrmT m g a) -> TrmT m g a +strict x = thunk $ liftM inject $ dimapM whnf' x + +-- | This combinator makes the evaluation of the given functor +-- application strict by evaluating all thunks of immediate subterms. +strict' :: (f :<: g, Ditraversable f, Monad m) => f (TrmT m g a) (TrmT m g a) -> TrmT m g a +strict' = strict . dimap Var id \ No newline at end of file diff --git a/compdata-param-master/testsuite/tests/Data/Comp/Examples/MultiParam.hs b/compdata-param-master/testsuite/tests/Data/Comp/Examples/MultiParam.hs new file mode 100755 index 0000000..dc57dee --- /dev/null +++ b/compdata-param-master/testsuite/tests/Data/Comp/Examples/MultiParam.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TypeOperators #-} +module Data.Comp.Examples.MultiParam where + +import Examples.Multi.FOL as FOL + +import Data.Comp.Param.Multi +import Data.Comp.Param.Multi.FreshM (Name) + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit + + + + + + +-------------------------------------------------------------------------------- +-- Test Suits +-------------------------------------------------------------------------------- + +tests = testGroup "Parametric Compositional Data Types" [ + testCase "FOL" folTest + ] + + +-------------------------------------------------------------------------------- +-- Properties +-------------------------------------------------------------------------------- + +folTest = show (foodFact7 :: INF Name TFormula) @=? "(Person(x1) and Food(x2)) -> (Food(Skol2(x1)) or Person(Skol6(x2)))\n" ++ + "(Person(x1) and Food(x2)) -> (Food(Skol2(x1)) or Eats(Skol6(x2), x2))\n" ++ + "(Person(x1) and Eats(x1, Skol2(x1)) and Food(x2)) -> (Person(Skol6(x2)))\n" ++ + "(Person(x1) and Eats(x1, Skol2(x1)) and Food(x2)) -> (Eats(Skol6(x2), x2))" diff --git a/compdata-param-master/testsuite/tests/Data/Comp/Examples/Param.hs b/compdata-param-master/testsuite/tests/Data/Comp/Examples/Param.hs new file mode 100755 index 0000000..3cc5147 --- /dev/null +++ b/compdata-param-master/testsuite/tests/Data/Comp/Examples/Param.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TypeOperators #-} +module Data.Comp.Examples.Param where + +import Examples.Names as Names +import Examples.Graph as Graph + +import Data.Comp.Param + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit + + + + + + +-------------------------------------------------------------------------------- +-- Test Suits +-------------------------------------------------------------------------------- + +tests = testGroup "Parametric Compositional Data Types" [ + testCase "names" namesTest, + testCase "graph" graphTest + ] + + +-------------------------------------------------------------------------------- +-- Properties +-------------------------------------------------------------------------------- + +instance (EqD f, PEq p) => EqD (f :&: p) where + eqD (v1 :&: p1) (v2 :&: p2) = do b1 <- peq p1 p2 + b2 <- eqD v1 v2 + return $ b1 && b2 + +namesTest = sequence_ [en @=? en', ep @=? ep'] +graphTest = sequence_ [n @=? 5, f @=? [0,2,1,2]] diff --git a/compdata-param-master/testsuite/tests/Data/Comp/Examples_Test.hs b/compdata-param-master/testsuite/tests/Data/Comp/Examples_Test.hs new file mode 100755 index 0000000..487a6a7 --- /dev/null +++ b/compdata-param-master/testsuite/tests/Data/Comp/Examples_Test.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeOperators #-} +module Data.Comp.Examples_Test where + +import qualified Data.Comp.Examples.Param as P +import qualified Data.Comp.Examples.MultiParam as MP + +import Test.Framework + +tests = testGroup "Examples" [ + P.tests, + MP.tests + ] diff --git a/compdata-param-master/testsuite/tests/Tests.hs b/compdata-param-master/testsuite/tests/Tests.hs new file mode 100755 index 0000000..437c238 --- /dev/null +++ b/compdata-param-master/testsuite/tests/Tests.hs @@ -0,0 +1,18 @@ +module Main where + +import Test.Framework +import qualified Data.Comp.Examples_Test + +-------------------------------------------------------------------------------- +-- Test Suits +-------------------------------------------------------------------------------- + +main = defaultMain [tests] + +tests = testGroup "Data.Comp" [ + Data.Comp.Examples_Test.tests + ] + +-------------------------------------------------------------------------------- +-- Properties +-------------------------------------------------------------------------------- diff --git a/compdata-param-master/upload-doc b/compdata-param-master/upload-doc new file mode 100755 index 0000000..fb216b1 --- /dev/null +++ b/compdata-param-master/upload-doc @@ -0,0 +1,17 @@ +#!/bin/bash + +# Usage: upload-doc compdata-param + +cabal haddock --hyperlink-source --html-location='http://hackage.haskell.org/package/$pkg/docs' --contents-location='http://hackage.haskell.org/package/$pkg' +cd "dist/doc/html" +DDIR="${1}-${2}-docs" +cp -r "${1}" "${DDIR}" && tar -c -v -z -f "${DDIR}.tar.gz" "${DDIR}" +CS=$? +if [ "${CS}" -eq "0" ]; then + echo "Uploading to Hackage…" + curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' --data-binary "@${DDIR}.tar.gz" "http://${3}:${4}@hackage.haskell.org/package/${1}-${2}/docs" + exit $? +else + echo "Error when packaging the documentation" + exit $CS +fi diff --git a/just do it - simple equational monadic reasoning.pdf b/just do it - simple equational monadic reasoning.pdf new file mode 100644 index 0000000..ffbc276 Binary files /dev/null and b/just do it - simple equational monadic reasoning.pdf differ diff --git a/learning-scalaz.pdf b/learning-scalaz.pdf new file mode 100644 index 0000000..e2482fb Binary files /dev/null and b/learning-scalaz.pdf differ diff --git a/limits.pdf b/limits.pdf new file mode 100644 index 0000000..2c6960a Binary files /dev/null and b/limits.pdf differ diff --git a/monads.pdf b/monads.pdf new file mode 100644 index 0000000..d8dadc7 Binary files /dev/null and b/monads.pdf differ diff --git a/push-pull-frp-slides.pdf b/push-pull-frp-slides.pdf new file mode 100644 index 0000000..df9d8c0 Binary files /dev/null and b/push-pull-frp-slides.pdf differ diff --git a/reader-monad-for-di.pdf b/reader-monad-for-di.pdf new file mode 100644 index 0000000..0ff676a Binary files /dev/null and b/reader-monad-for-di.pdf differ diff --git a/univ-algebra2012.pdf b/univ-algebra2012.pdf new file mode 100644 index 0000000..f8bfbbf Binary files /dev/null and b/univ-algebra2012.pdf differ diff --git a/universal_coalgebra.pdf b/universal_coalgebra.pdf new file mode 100644 index 0000000..4c6eb97 Binary files /dev/null and b/universal_coalgebra.pdf differ diff --git a/wgp10-genstorage.pdf b/wgp10-genstorage.pdf new file mode 100644 index 0000000..80b1216 Binary files /dev/null and b/wgp10-genstorage.pdf differ