packages feed

hypertypes (empty) → 0.1.0.1

raw patch · 85 files changed

+8500/−0 lines, 85 filesdep +QuickCheckdep +arraydep +basesetup-changed

Dependencies added: QuickCheck, array, base, base-compat, binary, constraints, containers, criterion, deepseq, generic-constraints, generic-data, hypertypes, lattices, lens, monad-st, mtl, pretty, show-combinators, template-haskell, text, th-abstraction, transformers

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for hypertypes++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER 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.
+ README.md view
@@ -0,0 +1,521 @@+# hypertypes: Types parameterised by hypertypes++Hypertypes enable constructing rich recursive types from individual components, and processing them generically with type classes.++They are a solution to the *Expression Problem*, as described by Phil Wadler (1998):++> The goal is to define a data type by cases, where one can add new cases to the data type and new functions over the data type, without recompiling existing code, and while retaining static type safety.++[*Data types a la carte*](http://www.cs.ru.nl/~W.Swierstra/Publications/DataTypesALaCarte.pdf) (DTALC, Swierstra, 2008) offers a solution for the expression problem which is only applicable for recursive expressions, without support for mutually recursive types. In practice, programming language ASTs do tend to be mutually recursive. [`multirec`](http://hackage.haskell.org/package/multirec) (Rodriguez et al, 2009) uses GADTs to encode mutually recursive types but in comparison to DTALC it lacks in the ability to construct the types from re-usable components.++Hypertypes allow constructing expressions from re-usable terms like DTALC, which can be rich mutually recursive types like in `multirec`.++The name "Hypertypes" is inspired by *Hyperfunctions* (S. Krstic et al, FICS 2001), which are a similar construct at the value level.++## Introduction to the "field constructor" pattern++### `Type`: Simple type, simple functionality++Suppose we have the following type in an application:++```Haskell+data Person = Person+    { height :: Double+    , weight :: Double+    }+```++Let's imagine that we want to let a user fill in a `Person` via a form,+where during the process the record may have missing fields.++We may want a way to represent a state with missing fields,+but this type doesn't allow for it.++We can either create an additional type for that, or augment `Person` to provide more functionality. Augmenting `Person` is preferred because it will result in less boiler-plate and less types to maintain as we make changes to it.++### `Type -> Type`: Adding a type parameter++A possible solution is to parameterize `Person` on the field type:++```Haskell+data Person a = Person+    { height :: a+    , weight :: a+    }+```++This would solve our problem.++We can parameterize with `Double` for the normal structure,+and with `Maybe Double` for the variant with missing fields.++This approach reaches its limits when the fields have multiple different types, as in:++```Haskell+data Person = Person+    { height :: Double+    , weight :: Double+    , name :: Text+    }+```++We would now need an additional parameter to parameterize how to store the fields of type `Text`!+Is there a way to use a single type parameter for both types of fields? Yes, there is:++### `(Type -> Type) -> Type`: Higher-Kinded Data++The ["Higher-Kinded Data"](https://reasonablypolymorphic.com/blog/higher-kinded-data/) pattern represents `Person` like so:++```Haskell+data Person f = Person+    { height :: f Double+    , weight :: f Double+    , name :: f Text+    }+```++For the plain case we would use `Person Identity`.++`Identity` from `Data.Functor.Identity` is defined as so:++```Haskell+data Identity a = Identity a+```++And for the variant with missing fields we would use `Person Maybe`.++The benefit of this parameterization over the previous one is that `Person`'s kind+doesn't need to change when adding more field types, so such changes don't propagate all over the code base.++Note that various helper classes such as+`Rank2.Functor`+and `Rank2.Traversable` (from the [`rank2classes`](https://hackage.haskell.org/package/rank2classes) package)+allow us to conveniently convert between `Person Identity` and `Person Maybe`.++#### HKD for nested structures++Let's employ the same transformation we did for `Person` to a more complicated data structure:++```Haskell+data Expr+    = Const Int+    | Add Expr Expr+    | Mul Expr Expr+```++The HKD form of `Expr` would be:++```Haskell+data Expr f+    = Const (f Int)+    | Add (f (Expr f)) (f (Expr f))+    | Mul (f (Expr f)) (f (Expr f))+```++This does allow representing nested structures with missing elements.+But classes like `Rank2.Functor` no longer work for it.+To understand why let's look at `Rank2.Functor`'s definition++```Haskell+class Functor f where+    (<$>) :: (forall a. p a -> q a) -> f p -> f q+```++The rank-2 function argument expects the field type `a` to stay the same when it changes `p` to `q`,+however in the above formulation of `Expr` the field type `Expr p` change to `Expr q` when changing the type parameter.++### `Type -> Type`: The DTALC and `recursion-schemes` approach++Another formulation of `Expr` is the same as the `Type -> Type` approach discussed above:++```Haskell+data Expr a+    = Const Int+    | Add a a+    | Mul a a+```++Notes:++* The [`recursion-schemes`](http://hackage.haskell.org/package/recursion-schemes) package can generate this type for us from the plain definition of `Expr` using `TemplateHaskell`+* DTALC also allows us to construct this type by combining standalone `Const`, `Add`, and `Mul` types with the `:+:` operator (i.e `Const Int :+: Add :+: Mul`)++This approach does have the single node type limitation, so we gave up on parameterizing over the `Int` in `Const`.+This is a big limitation, but as we'll see, we do get several advantages in return.++First, we can represent plain expressions as `Fix Expr`, using:++```Haskell+newtype Fix f = Fix (f (Fix f))+```++We can then use useful combinators from `recursion-schemes` for folding and processing of `Expr`s.++[`unification-fd`](http://hackage.haskell.org/package/unification-fd)+is a good example of the power of this approach.+It implements generic unification for ASTs,+where it uses the parameterization to represent sub-expressions via unification variables.++In constrast to the HKD approach, we can also use rich fix-points which store several different fix-points within, like `Diff`:++```Haskell+data Diff f+    = Same (f (Fix f))+    | SameTopLevel (f (Diff f))+    | Different (f (Fix f)) (f (Fix f))+```++(Note how `Diff` parameterizes `f` by both `Fix` and `Diff`)++The main drawback of this approach is that in practice ASTs tend to be mutually recursive datatypes. For example:++```Haskell+data Expr+    = Var Text+    | App Expr Expr+    | Lam Text Typ Expr+data Typ+    = IntT+    | FuncT Typ Typ+```++This type is an example for an AST which DTALC and `recursion-schemes` cannot represent.++Can the "field constructor" pattern be used to represent such ASTs? Yes:++### `(Index -> Type) -> Index -> Type`: The `multirec` approach++[`multirec`](http://hackage.haskell.org/package/multirec)'s way to define the above AST:++```Haskell+data Expr :: Index+data Typ :: Index++data AST :: (Index -> Type) -> Index -> Type where+    Var :: Text -> AST r Expr+    App :: r Expr -> r Expr -> AST r Expr+    Lam :: Text -> r Typ -> r Expr -> AST r Expr+    IntT :: AST r Typ+    FuncT :: r Typ -> r Typ -> AST r Typ+```++(this is a slight variant of `multirec`'s actual presentation, where for improved legibility `Index` is used rather than `Type`)++`multirec` offers various utilities to process such data types.+It offers [`HFunctor`](http://hackage.haskell.org/package/multirec-0.7.9/docs/Generics-MultiRec-HFunctor.html),+a variant of `Functor` for these structures, and various recursive combinators.++But `multirec` has several limitations:++* Using a single GADT for the data type limits composition and modularity.+* Invocations of `HFunctor` for a `Typ` node need to support transforming all indices of `AST`,+  including `Expr`, even though `Typ` doesn't have `Expr` child nodes.++## `hypertypes`'s approach++The `hypertypes` representation of the above AST example:++```Haskell+data Expr h+    = EVar Text+    | EApp (h :# Expr) (h :# Expr)+    | ELam Text (h :# Typ) (h :# Expr)+data Typ h+    = TInt+    | TFunc (h :# Typ) (h :# Typ)+```++Sub-expressions are nested using the `:#` type operator. On the left side of `:#` is `Expr`'s type parameter `h` which is the "nest type", and on the right side `Expr` and `Typ` are the nested nodes.++`:#` is defined as:++```Haskell+-- A type parameterized by a hypertype+type HyperType = AHyperType -> Type++-- A kind for hypertypes+newtype AHyperType = AHyperType { getHyperType :: HyperType }++-- GetHyperType is getHyperType lifted to the type level+type family GetHyperType h where+    GetHyperType ('AHyperType t) = t++type p :# q = (GetHyperType p) ('AHyperType q)+-- AHyperType is DataKinds syntax for using AHyperType in types+```++The `hypertypes` library provides:++* Variants of standard classes like `Functor` with `TemplateHaskell` derivations for hypertypes.+  (Unlike in `multirec`'s `HFunctor`, only the actual child node types of each node need to be handled)+* Combinators for recursive processing and transformation of nested structures+* Implementations of common AST terms+* A unification implementation for mutually recursive types inspired by `unification-fd`+* A generic and fast implementation of Hindley-Milner type inference ("Efficient generalization with levels" as described in [*How OCaml type checker works*](http://okmij.org/ftp/ML/generalization.html), Kiselyov, 2013)++## Constructing types from individual components++Note that another way to formulate the above expression would be using pre-existing parts, such as:++```Haskell+data RExpr h+    = RVar (Var Text RExpr h)+    | RApp (App RExpr h)+    | RLam (TypedLam Text Typ RExpr h)+    deriving (Generic, Generic1, HNodes, HFunctor, HFoldable, HTraversable, ZipMatch)+```++This form supports using `DeriveAnyClass` to derive instances for various `HyperType` classes such as `HFunctor` based on `Generic1`. Note that due to a technical limitation of `Generic1` the form of `Expr` from before, which directly nests values, doesn't have a `Generic1` instance (so the instances for `Expr` are derived using `TemplateHaskell` instead).++## Examples++How do we represent an expression of the example language declared above?++Let's start with the verbose way:++```Haskell+verboseExpr :: Pure # Expr+verboseExpr =+    Pure (ELam "x" (Pure TInt) (Pure (EVar "x")))+```++Explanations for the above:++* `Pure # Expr` is a type synonym for `Pure ('AHyperType Expr)`+* `Pure` is the simplest "pass-through" nest type+* The above is quite verbose with a lot of instances of `Pure` and many parentheses+* Writing an expression of the above `RExpr` would be even more verbose due to additional `Var` and `TypedLam` data constructors!++To write it more consicely, the `HasHPlain` class, along with a `TemplateHaskell` generator for it, exists:++```Haskell+> let e = hPlain :# verboseExpr+-- Note: This (#) comes from Control.Lens++> e+ELamP "x" TIntP (EVarP "x")++> :t e+e :: HPlain Expr+```++It's now easier to see that `e` represents `λ(x:Int). x`++`HPlain` is a data family of "plain versions" of expressions, generated via `TemplateHaskell`. Note that it flattens embedded constructors for maximal convinience, so that the plain version of `RExpr` is as convinient to use as that of `Expr`!++This is somewhat similar to how `recursion-schemes` can derive a parameterized version of an AST, but is the other way around: the parameterized type is the source and the plain one is generated.++So now, let's define some example expressions concisely:++```Haskell+exprA, exprB :: HPlain Expr++exprA = ELamP "x" IntTP (EVarP "x")++exprB = ELamP "x" (TFuncP TIntP TIntP) (EVarP "x")+```++What can we do with these expressions?+Let's compute a diff:++```Haskell+> let d = diffP exprA exprB++> d+CommonBodyP+(ELam "x"+    (DifferentP TIntP (TFuncP TIntP TIntP))+    (CommonSubTreeP (EVarP "x"))+)++> :t d+d :: DiffP # Expr+-- (An Expr with the DiffP nest type)+```++Let's see the type of `diffP`:++```Haskell+> :t diffP+diffP ::+    ( RTraversable h+    , Recursively ZipMatch h+    , Recursively HasHPlain h+    ) =>+    HPlain h -> HPlain h -> DiffP # h+```++`diffP` can compute the diff for any AST that is recursively traversable, can be matched, and has a plain representation.++Now, let's format this diff better:++```Haskell+> let formatDiff _ x y = "- " <> show x <> "\n+ " <> show y <> "\n"++> putStrLn (foldDiffsP formatDiff d)+- TIntP++ TFuncP TIntP TIntP++> :t foldDiffsP+foldDiffsP ::+    ( Monoid r+    , Recursively HFoldable h+    , Recursively HasHPlain h+    ) =>+    (forall n. HasHPlain n => HRecWitness h n -> HPlain n -> HPlain n -> r) ->+    DiffP # h ->+    r+```++Why is the ignored argument of `formatDiff` there? It is the `HRecWitness h n` from the type of `foldDiffsP` above. It is a witness that "proves" that the folded node `n` is a recursive node of `h`, essentially restricting the `forall n.` to `n`s that are recursive nodes of `h`.++## Witness parameters++*First, I want to give thanks and credit: We learned of this elegant solution from `multirec`!*++What are witness parameters?++Let's look at how `HFunctor` is defined:++```Haskell+class HNodes h => HFunctor h where+    -- | 'HFunctor' variant of 'fmap'+    hmap ::+        (forall n. HWitness h n -> p # n -> q # n) ->+        h # p ->+        h # q+```++`HFunctor` can change an `h`'s nest-type from `p` to `q`.++`HWitness` is a data family which is a member of `HNodes`.++For example, let's see the definition of `Expr`'s `HWitness`:++```Haskell+data instance HWitness Expr n where+    W_Expr_Expr :: HWitness Expr Expr+    W_Expr_Typ :: HWitness Expr Typ+```++Note that this GADT is automatically generated via `TemplateHaskell`.++What does the witness give us? It restricts `forall n.` to the nodes of `h`.+When mapping over an `Expr` we can:++* Ignore the witness and use a mapping from a `p` of any `n` to a `q` of it+* Pattern match on the witness to handle `Expr`'s specific node types+* Use the `#>` operator to convert the witness to a class constraint on `n`.++## Understanding `HyperType`s++* We want structures to be parameterized by nest-types+* Nest-types are parameterized by the structures, too+* Therefore, structures and their nest-types need to be parameterized by each other+* This results in infinite types, as the structure is parameterized by something which may be parameterized by the structure itself.++`multirec` ties this knot by using indices to represent types. `hypertypes` does this by using `DataKinds` and the `AHyperType` `newtype` which is used for both structures and their nest-types. An implication of the two being the same is that the same classes and combinators are re-used for both.++## What Haskell is this++`hypertypes` is implemented with GHC and heavily relies on quite a few language extensions:++* `ConstraintKinds` and `TypeFamilies` are needed for the `HNodesConstraint` type family that lifts a constraint to apply over a value's nodes. Type families are also used to encode term's results in type inference.+* `DataKinds` allows parameterizing types over `AHyperType`s+* `DefaultSignatures` are used for default methods that return `Dict`s to avoid undecidable super-classes+* `DeriveGeneric`, `DerivingVia`, `GeneralizedNewtypeDeriving`, `StandaloneDeriving` and `TemplateHaskell` are used to derive type-class instances+* `EmptyCase` is needed for instances of leaf nodes+* `FlexibleContexts`, `FlexibleInstances` and `UndecidableInstances` are required to specify many constraints+* `GADTs` and `RankNTypes` enable functions like `hmap` which get `forall`ed functions with witness parameters+* `MultiParamTypeClasses` is needed for the `Unify` and `Infer` type classes+* `ScopedTypeVariables` and `TypeApplications` assist writing short code that type checks++Many harmless syntactic extensions are also used:++* `DerivingStrategies`, `LambdaCase`, `TupleSections`, `TypeOperators`++Some extensions we use but would like to avoid (we're looking for alternative solutions but haven't found them):++## How does hypertypes compare/relate to++Note that comparisons to `multirec`, HKD, `recursion-schemes`, `rank2classes`, and `unification-fd` were discussed above.++In addition:++### hyperfunctions++S. Krstic et al [KLP2001] have described the a type which they call a "Hyperfunction". Here is it's definition from the [`hyperfunctions`](http://hackage.haskell.org/package/hyperfunctions) package:++```Haskell+newtype Hyper a b = Hyper { invoke :: Hyper b a -> b }+```++`AHyperType`s are isomorphic to `Hyper Type Type` (assuming a `PolyKinds` variant of `Hyper`), so they can be seen as type-level "hyperfunctions".++For more info on hyperfunctions and their use cases in the value level see [LKS2013]++#### References++* [KLP2001] S. Krstic, J. Launchbury, and D. Pavlovic. Hyperfunctions. In Proceeding of Fixed Points in Computer Science, FICS 2001+* [LKS2013] J. Launchbury, S. Krstic, T. E. Sauerwein. [Coroutining Folds with Hyperfunctions](https://arxiv.org/abs/1309.5135). In In Proceedings Festschrift for Dave Schmidt, EPTCS 2013++### Data Types a la Carte++In addition to the external fix-points described above, [Data Types a la Carte](http://www.staff.science.uu.nl/~swier004/publications/2008-jfp.pdf) (DTALC) also describes how to define ASTs structurally.++I.e, rather than having++```Haskell+data Expr a+    = Val Int+    | Add a a -- "a" stands for a sub-expression (recursion-schemes style)+```++We can have++```Haskell+newtype Val a = Val Int++data Add a = Add a a++-- Expr is a structural sum of Val and Add+type Expr = Val :+: Add+```++This enables re-usability of the AST elements `Val` and `Add` in various ASTs, where the functionality is shared via type classes. Code using these type classes can work generically for different ASTs.++Like DTALC, `hypertypes` has:++* Instances type for combinators such as `:+:` and `:*:`, so that these can be used to build ASTs+* Implementations of common AST terms in the `Hyper.Type.AST` module hierarchy (`App`, `Lam`, `Let`, `Var`, `TypeSig` and others)+* Classes like `HFunctor`, `HTraversable`, `Unify`, `Infer` with instances for the provided AST terms++As an example of a reusable term let's look at the definition of `App`:++```Haskell+-- | A term for function applications.+data App expr h = App+    { _appFunc :: h :# expr+    , _appArg :: h :# expr+    }+```++Unlike a DTALC-based apply, which would be parameterized by a single type parameter `(a :: Type)`, `App` is parameterized on two type parameters, `(expr :: HyperType)` and `(h :: AHyperType)`. `expr` represents the node type of `App expr`'s child nodes and `h` is the tree's fix-point. This enables using `App` in mutually recursive ASTs where it may be parameterized by several different `expr`s.++Unlike the original DTALC paper which isn't suitable for mutually recursive ASTs, in `hypertypes` one would have to declare an explicit expression type for each expression type for use as `App`'s `expr` type parameter. Similarly, `multirec`'s DTALC variant also requires explicitly declaring type indices.++While it is possible to declare ASTs as `newtype`s wrapping `:+:`s of existing terms and deriving all the instances via `GeneralizedNewtypeDeriving`, our usage and examples declare types in the straight forward way, with named data constructors, as we think results in more readable and performant code.++### bound++[`bound`](http://hackage.haskell.org/package/bound) is a library for expressing ASTs with type-safe De-Bruijn indices rather than parameter names, via an AST type constructor that is indexed on the variables in scope.++An intereseting aspect of `bound`'s ASTs is that recursively they are made of an infinite amount of types.++When implementing `hypertypes` we had the explicit goal of making sure that such ASTs are expressible with it,+and for this reason the `Hyper.Type.AST.NamelessScope` module in the tests implementing it is provided, and the test suite includes+a language implementation based on it (`LangA` in the tests).++### lens++`hypertypes` strives to be maximally compatible with [`lens`](http://hackage.haskell.org/package/lens), and offers `Traversal`s and `Setter`s wherever possible. But unfortunately the `RankNTypes` nature of many combinators in hypertypes makes them not composable with optics. For the special simpler cases when all child nodes have the same types the `htraverse1` traversal and `hmapped1` setter are available.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hypertypes.cabal view
@@ -0,0 +1,238 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack+--+-- hash: d25a0b3f8c7b76db97429b9b8756f4f2966f3352a921733dd51db840869bb422++name:           hypertypes+version:        0.1.0.1+synopsis:       Typed ASTs+description:    Please see the README on GitHub at <https://github.com/lamdu/hypertypes#readme>+category:       Algorithms, Compilers/Interpreters, Language, Logic, Unification+homepage:       https://github.com/lamdu/hypertypes#readme+bug-reports:    https://github.com/lamdu/hypertypes/issues+author:         Yair Chuchem+maintainer:     yairchu@gmail.com+copyright:      2018 Yair Chuchem"+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/lamdu/hypertypes++library+  exposed-modules:+      Hyper+      Hyper.Class.Apply+      Hyper.Class.Context+      Hyper.Class.Foldable+      Hyper.Class.Functor+      Hyper.Class.HasPlain+      Hyper.Class.Infer+      Hyper.Class.Infer.Env+      Hyper.Class.Infer.InferOf+      Hyper.Class.Monad+      Hyper.Class.Morph+      Hyper.Class.Nodes+      Hyper.Class.Optic+      Hyper.Class.Pointed+      Hyper.Class.Recursive+      Hyper.Class.Traversable+      Hyper.Class.Unify+      Hyper.Class.ZipMatch+      Hyper.Combinator.Ann+      Hyper.Combinator.ANode+      Hyper.Combinator.Compose+      Hyper.Combinator.Flip+      Hyper.Combinator.Func+      Hyper.Diff+      Hyper.Infer+      Hyper.Infer.Blame+      Hyper.Infer.Result+      Hyper.Infer.ScopeLevel+      Hyper.Recurse+      Hyper.TH.Apply+      Hyper.TH.Context+      Hyper.TH.Foldable+      Hyper.TH.Functor+      Hyper.TH.HasPlain+      Hyper.TH.Morph+      Hyper.TH.Nodes+      Hyper.TH.Pointed+      Hyper.TH.Traversable+      Hyper.TH.ZipMatch+      Hyper.Type+      Hyper.Type.AST.App+      Hyper.Type.AST.FuncType+      Hyper.Type.AST.Lam+      Hyper.Type.AST.Let+      Hyper.Type.AST.Map+      Hyper.Type.AST.Nominal+      Hyper.Type.AST.Row+      Hyper.Type.AST.Scheme+      Hyper.Type.AST.Scheme.AlphaEq+      Hyper.Type.AST.TypedLam+      Hyper.Type.AST.TypeSig+      Hyper.Type.AST.Var+      Hyper.Type.Functor+      Hyper.Type.Prune+      Hyper.Type.Pure+      Hyper.Unify+      Hyper.Unify.Binding+      Hyper.Unify.Binding.Save+      Hyper.Unify.Binding.ST+      Hyper.Unify.Binding.ST.Load+      Hyper.Unify.Constraints+      Hyper.Unify.Error+      Hyper.Unify.Generalize+      Hyper.Unify.New+      Hyper.Unify.Occurs+      Hyper.Unify.QuantifiedVar+      Hyper.Unify.Term+  other-modules:+      Hyper.Internal.Prelude+      Hyper.TH.Internal.Utils+  hs-source-dirs:+      src+  default-extensions:+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveGeneric+      DerivingStrategies+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      MultiParamTypeClasses+      RankNTypes+      ScopedTypeVariables+      StandaloneDeriving+      TupleSections+      TypeApplications+      TypeOperators+      TypeFamilies+      NoImplicitPrelude+  ghc-options: -fexpose-all-unfoldings -Wall -Wcompat -Wredundant-constraints -Wnoncanonical-monad-instances -Wincomplete-record-updates -Wincomplete-uni-patterns+  ghc-prof-options: -fexpose-all-unfoldings+  build-depends:+      QuickCheck+    , array+    , base >=4.9 && <5+    , base-compat+    , binary+    , constraints+    , containers+    , deepseq+    , generic-constraints+    , generic-data+    , lattices+    , lens+    , monad-st+    , mtl+    , pretty+    , show-combinators+    , template-haskell+    , th-abstraction >=0.3+    , transformers+  default-language: Haskell2010++test-suite hypertypes-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Hyper.Class.Infer.Infer1+      Hyper.Type.AST.NamelessScope+      Hyper.Type.AST.NamelessScope.InvDeBruijn+      LangA+      LangB+      LangC+      LangD+      ReadMeExamples+      TypeLang+      Paths_hypertypes+  hs-source-dirs:+      test+  default-extensions:+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveGeneric+      DerivingStrategies+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      MultiParamTypeClasses+      RankNTypes+      ScopedTypeVariables+      StandaloneDeriving+      TupleSections+      TypeApplications+      TypeOperators+      TypeFamilies+  ghc-options: -fexpose-all-unfoldings -Wall -Wcompat -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  ghc-prof-options: -fexpose-all-unfoldings+  build-depends:+      base >=4.9 && <5+    , constraints+    , containers+    , generic-constraints+    , generic-data+    , hypertypes+    , lattices+    , lens+    , monad-st+    , mtl+    , pretty+    , text+    , transformers+  default-language: Haskell2010++benchmark hypertypes-bench+  type: exitcode-stdio-1.0+  main-is: Benchmark.hs+  other-modules:+      LangB+      TypeLang+  hs-source-dirs:+      test+  default-extensions:+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveGeneric+      DerivingStrategies+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      MultiParamTypeClasses+      RankNTypes+      ScopedTypeVariables+      StandaloneDeriving+      TupleSections+      TypeApplications+      TypeOperators+      TypeFamilies+  ghc-options: -fexpose-all-unfoldings -Wall -Wcompat -Wredundant-constraints -O2 -Wnoncanonical-monad-instances -Wincomplete-record-updates -Wincomplete-uni-patterns+  ghc-prof-options: -fexpose-all-unfoldings+  build-depends:+      base >=4.9 && <5+    , constraints+    , containers+    , criterion+    , generic-constraints+    , generic-data+    , hypertypes+    , lattices+    , lens+    , monad-st+    , mtl+    , pretty+    , transformers+  default-language: Haskell2010
+ src/Hyper.hs view
@@ -0,0 +1,29 @@+-- | A convinience module which re-exports common functionality of the hypertypes library++module Hyper (module X) where++import Data.Constraint as X (Constraint, Dict(..), withDict)+import Data.Functor.Const as X (Const(..))+import Data.Proxy as X (Proxy(..))+import GHC.Generics as X (Generic, (:*:)(..))+import Hyper.Class.Apply as X (HApply(..), HApplicative, liftH2)+import Hyper.Class.Foldable as X (HFoldable(..), hfoldMap, hfolded1, htraverse_, htraverse1_)+import Hyper.Class.Functor as X (HFunctor(..), hmapped1)+import Hyper.Class.HasPlain as X (HasHPlain(..))+import Hyper.Class.Nodes as X (HNodes(..), HWitness(..), _HWitness, (#>), (#*#))+import Hyper.Class.Pointed as X (HPointed(..))+import Hyper.Class.Recursive as X (Recursively(..), RNodes, RTraversable)+import Hyper.Class.Traversable as X (HTraversable(..), htraverse, htraverse1)+import Hyper.Combinator.Ann as X+import Hyper.Combinator.ANode as X+import Hyper.Combinator.Compose as X (HCompose(..), _HCompose, hcomposed)+import Hyper.Combinator.Flip as X+import Hyper.Combinator.Func as X+import Hyper.TH.Apply as X (makeHApplicativeBases)+import Hyper.TH.Context as X (makeHContext)+import Hyper.TH.HasPlain as X (makeHasHPlain)+import Hyper.TH.Morph as X (makeHMorph)+import Hyper.TH.Traversable as X (makeHTraversableApplyAndBases, makeHTraversableAndBases)+import Hyper.TH.ZipMatch as X (makeZipMatch)+import Hyper.Type as X+import Hyper.Type.Pure as X
+ src/Hyper/Class/Apply.hs view
@@ -0,0 +1,48 @@+-- | A variant of 'Data.Functor.Apply.Apply' for 'Hyper.Type.HyperType's++module Hyper.Class.Apply+    ( HApply(..), HApplicative+    , liftH2+    ) where++import Hyper.Class.Functor (HFunctor(..))+import Hyper.Class.Nodes (HWitness)+import Hyper.Class.Pointed (HPointed)+import Hyper.Type (type (#))++import Hyper.Internal.Prelude++-- | A variant of 'Data.Functor.Apply.Apply' for 'Hyper.Type.HyperType's.+--+-- A type which has 'HApply' and 'HPointed' instances also has 'HApplicative',+-- which is the equivalent to the 'Applicative' class.+class HFunctor h => HApply h where+    -- | Combine child values+    --+    -- >>> hzip (Person name0 age0) (Person name1 age1)+    -- Person (Pair name0 name1) (Pair age0 age1)+    hzip ::+        h # p ->+        h # q ->+        h # (p :*: q)++-- | A variant of 'Applicative' for 'Hyper.Type.HyperType's.+type HApplicative h = (HPointed h, HApply h)++instance Semigroup a => HApply (Const a) where+    {-# INLINE hzip #-}+    hzip (Const x) (Const y) = Const (x <> y)++instance (HApply a, HApply b) => HApply (a :*: b) where+    {-# INLINE hzip #-}+    hzip (a0 :*: b0) (a1 :*: b1) = hzip a0 a1 :*: hzip b0 b1++-- | 'HApply' variant of 'Control.Applicative.liftA2'+{-# INLINE liftH2 #-}+liftH2 ::+    HApply h =>+    (forall n. HWitness h n -> p # n -> q # n -> r # n) ->+    h # p ->+    h # q ->+    h # r+liftH2 f x = hmap (\w (a :*: b) -> f w a b) . hzip x
+ src/Hyper/Class/Context.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}++module Hyper.Class.Context+    ( HContext(..)+    , recursiveContexts, annContexts+    ) where++import Control.Lens (mapped, from, _Wrapped, _1, _2)+import Hyper.Combinator.Compose (HCompose(..), _HCompose, decompose)+import Hyper.Combinator.Flip+import Hyper.Combinator.Func (HFunc(..), _HFunc)+import Hyper.Class.Functor (HFunctor(..))+import Hyper.Class.Nodes ((#*#), (#>))+import Hyper.Class.Recursive (Recursively(..))+import Hyper.Combinator.Ann (Ann(..))+import Hyper.Type (type (#))+import Hyper.Type.Pure (Pure(..), _Pure)++import Hyper.Internal.Prelude++class HContext h where+    -- | Add next to each node a function to replace it in the parent with a different value+    hcontext ::+        h # p ->+        h # (HFunc p (Const (h # p)) :*: p)++instance HContext Pure where+    hcontext = _Pure %~ \x -> HFunc (Const . Pure) :*: x++instance (HContext a, HFunctor a) => HContext (Ann a) where+    hcontext (Ann a b) =+        Ann+        (hmap (const (_1 . _HFunc . mapped . _Wrapped %~ (`Ann` b))) (hcontext a))+        (HFunc (Const . Ann a) :*: b)++instance (HFunctor h0, HContext h0, HFunctor h1, HContext h1) => HContext (HCompose h0 h1) where+    hcontext =+        _HCompose %~+        hmap+        ( \_ (HFunc c0 :*: x0) ->+            x0 & _HCompose %~+            hmap+            ( \_ (HFunc c1 :*: x1) ->+                x1 & _HCompose %~+                (HFunc (Const . (_HCompose #) . getConst . c0 . (_HCompose #) . getConst . c1 . (_HCompose #)) :*:)+            ) . hcontext+        ) . hcontext++instance (Recursively HContext h, Recursively HFunctor h) => HContext (HFlip Ann h) where+    -- The context of (HFlip Ann h) differs from annContexts in that+    -- only the annotation itself is replaced rather than the whole subexpression.+    hcontext =+        hmap (const (_1 . _HFunc . mapped . _Wrapped %~ (_HFlip #))) . (from hflipped %~ f . annContexts)+        where+            f ::+                forall n p r.+                Recursively HFunctor n =>+                Ann (HFunc (Ann p) (Const r) :*: p) # n -> Ann (HFunc p (Const r) :*: p) # n+            f (Ann (HFunc func :*: a) b) =+                withDict (recursively (Proxy @(HFunctor n))) $+                Ann (HFunc (func . (`Ann` g b)) :*: a) (hmap (Proxy @(Recursively HFunctor) #> f) b)+            g ::+                forall n a b.+                Recursively HFunctor n => n # Ann (a :*: b) -> n # Ann b+            g =+                withDict (recursively (Proxy @(HFunctor n))) $+                hmap (Proxy @(Recursively HFunctor) #> hflipped %~ hmap (const (^. _2)))++-- | Add in the node annotations a function to replace each node in the top-level node+recursiveContexts ::+    (Recursively HContext h, Recursively HFunctor h, Recursively HContext p, Recursively HFunctor p) =>+    p # h ->+    HCompose (Ann (HFunc Pure (Const (p # h)))) p # h+recursiveContexts = recursiveContextsWith . (HFunc Const :*:)++recursiveContextsWith ::+    forall h p r.+    (Recursively HContext h, Recursively HFunctor h, Recursively HContext p, Recursively HFunctor p) =>+    (HFunc p (Const r) :*: p) # h ->+    HCompose (Ann (HFunc Pure (Const r))) p # h+recursiveContextsWith (HFunc s0 :*: x0) =+    withDict (recursively (Proxy @(HFunctor p))) $+    withDict (recursively (Proxy @(HFunctor h))) $+    withDict (recursively (Proxy @(HContext p))) $+    withDict (recursively (Proxy @(HContext h))) $+    _HCompose # Ann+    { _hAnn = _HFunc # Const . getConst . s0 . (^. decompose)+    , _hVal =+        _HCompose #+        hmap+        ( Proxy @(Recursively HContext) #*# Proxy @(Recursively HFunctor) #>+            \(HFunc s1 :*: x1) ->+            _HCompose #+            hmap+            ( Proxy @(Recursively HContext) #*# Proxy @(Recursively HFunctor) #>+                \(HFunc s2 :*: x2) ->+                recursiveContextsWith (HFunc (Const . getConst . s0 . getConst . s1 . getConst . s2) :*: x2)+            ) (hcontext x1)+        ) (hcontext x0)+    }++-- | Add in the node annotations a function to replace each node in the top-level node+--+-- It is possible to define annContexts in terms of 'recursiveContexts' but the conversion is quite unwieldy.+annContexts ::+    (Recursively HContext h, Recursively HFunctor h) =>+    Ann p # h ->+    Ann (HFunc (Ann p) (Const (Ann p # h)) :*: p) # h+annContexts = annContextsWith . (HFunc Const :*:)++annContextsWith ::+    forall h p r.+    (Recursively HContext h, Recursively HFunctor h) =>+    (HFunc (Ann p) (Const r) :*: Ann p) # h ->+    Ann (HFunc (Ann p) (Const r) :*: p) # h+annContextsWith (HFunc s0 :*: Ann a b) =+    withDict (recursively (Proxy @(HContext h))) $+    withDict (recursively (Proxy @(HFunctor h)))+    Ann+    { _hAnn = HFunc s0 :*: a+    , _hVal =+        hmap+        ( Proxy @(Recursively HContext) #*# Proxy @(Recursively HFunctor) #>+            \(HFunc s1 :*: x) ->+            annContextsWith (HFunc (Const . getConst . s0 . Ann a . getConst . s1) :*: x)+        ) (hcontext b)+    }
+ src/Hyper/Class/Foldable.hs view
@@ -0,0 +1,92 @@+-- | A variant of 'Foldable' for 'Hyper.Type.HyperType's++{-# LANGUAGE FlexibleContexts #-}++module Hyper.Class.Foldable+    ( HFoldable(..)+    , hfolded1+    , htraverse_, htraverse1_+    ) where++import Control.Lens (Fold, folding)+import GHC.Generics+import Hyper.Class.Nodes (HNodes(..), HWitness(..), _HWitness, (#>))+import Hyper.Type (type (#))++import Hyper.Internal.Prelude++-- | A variant of 'Foldable' for 'Hyper.Type.HyperType's+class HNodes h => HFoldable h where+    -- | 'HFoldable' variant of 'foldMap'+    --+    -- Gets a function from @h@'s nodes (trees along witnesses that they are nodes of @h@)+    -- into a monoid and concats its results for all nodes.+    hfoldMap ::+        Monoid a =>+        (forall n. HWitness h n -> p # n -> a) ->+        h # p ->+        a+    {-# INLINE hfoldMap #-}+    default hfoldMap ::+        ( Generic1 h, HFoldable (Rep1 h), HWitnessType h ~ HWitnessType (Rep1 h)+        , Monoid a+        ) =>+        (forall n. HWitness h n -> p # n -> a) ->+        h # p ->+        a+    hfoldMap f = hfoldMap (f . (_HWitness %~ id)) . from1++instance HFoldable (Const a) where+    {-# INLINE hfoldMap #-}+    hfoldMap _ _ = mempty++instance (HFoldable a, HFoldable b) => HFoldable (a :*: b) where+    {-# INLINE hfoldMap #-}+    hfoldMap f (x :*: y) =+        hfoldMap (f . HWitness . L1) x <>+        hfoldMap (f . HWitness . R1) y++instance (HFoldable a, HFoldable b) => HFoldable (a :+: b) where+    {-# INLINE hfoldMap #-}+    hfoldMap f (L1 x) = hfoldMap (f . HWitness . L1) x+    hfoldMap f (R1 x) = hfoldMap (f . HWitness . R1) x++deriving newtype instance HFoldable h => HFoldable (M1 i m h)+deriving newtype instance HFoldable h => HFoldable (Rec1 h)++-- | 'HFoldable' variant for 'Control.Lens.folded' for 'Hyper.Type.HyperType's with a single node type.+--+-- Avoids using @RankNTypes@ and thus can be composed with other optics.+{-# INLINE hfolded1 #-}+hfolded1 ::+    forall h n p.+    ( HFoldable h+    , HNodesConstraint h ((~) n)+    ) =>+    Fold (h # p) (p # n)+hfolded1 =+    folding (hfoldMap @_ @[p # n] (Proxy @((~) n) #> pure))++-- | 'HFoldable' variant of 'Data.Foldable.traverse_'+--+-- Applise a given action on all subtrees+-- (represented as trees along witnesses that they are nodes of @h@)+{-# INLINE htraverse_ #-}+htraverse_ ::+    (Applicative f, HFoldable h) =>+    (forall c. HWitness h c -> m # c -> f ()) ->+    h # m ->+    f ()+htraverse_ f = sequenceA_ . hfoldMap (fmap (:[]) . f)++-- | 'HFoldable' variant of 'Data.Foldable.traverse_' for 'Hyper.Type.HyperType's with a single node type (avoids using @RankNTypes@)+{-# INLINE htraverse1_ #-}+htraverse1_ ::+    forall f h n p.+    ( Applicative f, HFoldable h+    , HNodesConstraint h ((~) n)+    ) =>+    (p # n -> f ()) ->+    h # p ->+    f ()+htraverse1_ f = htraverse_ (Proxy @((~) n) #> f)
+ src/Hyper/Class/Functor.hs view
@@ -0,0 +1,71 @@+-- | A variant of 'Functor' for 'Hyper.Type.HyperType's++{-# LANGUAGE FlexibleContexts #-}++module Hyper.Class.Functor+    ( HFunctor(..)+    , hmapped1+    , hiso+    ) where++import Control.Lens (Setter, Iso', sets, iso)+import GHC.Generics+import Hyper.Class.Nodes (HNodes(..), HWitness(..), _HWitness, (#>))+import Hyper.Type (type (#))++import Hyper.Internal.Prelude++-- | A variant of 'Functor' for 'HyperType's+class HNodes h => HFunctor h where+    -- | 'HFunctor' variant of 'fmap'+    --+    -- Applied a given mapping for @h@'s nodes (trees along witnesses that they are nodes of @h@)+    -- to result with a new tree, potentially with a different nest type.+    hmap ::+        (forall n. HWitness h n -> p # n -> q # n) ->+        h # p ->+        h # q+    {-# INLINE hmap #-}+    default hmap ::+        (Generic1 h, HFunctor (Rep1 h), HWitnessType h ~ HWitnessType (Rep1 h)) =>+        (forall n. HWitness h n -> p # n -> q # n) ->+        h # p ->+        h # q+    hmap f = to1 . hmap (f . (_HWitness %~ id)) . from1++instance HFunctor (Const a) where+    {-# INLINE hmap #-}+    hmap _ (Const x) = Const x++instance (HFunctor a, HFunctor b) => HFunctor (a :*: b) where+    {-# INLINE hmap #-}+    hmap f (x :*: y) =+        hmap (f . HWitness . L1) x :*:+        hmap (f . HWitness . R1) y++instance (HFunctor a, HFunctor b) => HFunctor (a :+: b) where+    {-# INLINE hmap #-}+    hmap f (L1 x) = L1 (hmap (f . HWitness . L1) x)+    hmap f (R1 x) = R1 (hmap (f . HWitness . R1) x)++deriving newtype instance HFunctor h => HFunctor (M1 i m h)+deriving newtype instance HFunctor h => HFunctor (Rec1 h)++-- | 'HFunctor' variant of 'Control.Lens.mapped' for 'Hyper.Type.HyperType's with a single node type.+--+-- Avoids using @RankNTypes@ and thus can be composed with other optics.+{-# INLINE hmapped1 #-}+hmapped1 ::+    forall h n p q.+    (HFunctor h, HNodesConstraint h ((~) n)) =>+    Setter (h # p) (h # q) (p # n) (q # n)+hmapped1 = sets (\f -> hmap (Proxy @((~) n) #> f))++-- | Define 'Iso's for 'HFunctor's+--+-- TODO: Is there an equivalent for this in lens that we can name this after?+hiso ::+    HFunctor h =>+    (forall n. HWitness h n -> Iso' (p # n) (q # n)) ->+    Iso' (h # p) (h # q)+hiso f = iso (hmap (\w -> (^. f w))) (hmap (\w -> (f w #)))
+ src/Hyper/Class/HasPlain.hs view
@@ -0,0 +1,23 @@+-- | A class for plain 'Data.Kind.Type' equivalents+-- for the simple forms of 'Hyper.Type.HyperType's.+--+-- Useful for succinct tests, examples, and for debug prints.++{-# LANGUAGE FlexibleContexts #-}++module Hyper.Class.HasPlain+    ( HasHPlain(..)+    ) where++import Control.Lens (Iso')+import Hyper.Type (type (#))+import Hyper.Type.Pure (Pure)++import Prelude.Compat++-- | A class for a plain form of a @Pure # h@+class Show (HPlain h) => HasHPlain h where+    -- | Plain form data type+    data HPlain h+    -- | An 'Control.Lens.Iso' between the plain form and 'Hyper.Type.HyperType' form+    hPlain :: Iso' (HPlain h) (Pure # h)
+ src/Hyper/Class/Infer.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, FlexibleContexts #-}++module Hyper.Class.Infer+    ( InferOf+    , Infer(..)+    , InferChild(..), _InferChild+    , InferredChild(..), inType, inRep+    ) where++import qualified Control.Lens as Lens+import           GHC.Generics+import           Hyper+import           Hyper.Class.Unify+import           Hyper.Recurse++import           Hyper.Internal.Prelude++-- | @InferOf e@ is the inference result of @e@.+--+-- Most commonly it is an inferred type, using+--+-- > type instance InferOf MyTerm = ANode MyType+--+-- But it may also be other things, for example:+--+-- * An inferred value (for types inside terms)+-- * An inferred type together with a scope+type family InferOf (t :: HyperType) :: HyperType++-- | A 'HyperType' containing an inferred child node+data InferredChild v h t = InferredChild+    { _inRep :: !(h t)+        -- ^ Inferred node.+        --+        -- An 'inferBody' implementation needs to place this value in the corresponding child node of the inferred term body+    , _inType :: !(InferOf (GetHyperType t) # v)+        -- ^ The inference result for the child node.+        --+        -- An 'inferBody' implementation may use it to perform unifications with it.+    }+makeLenses ''InferredChild++-- | A 'HyperType' containing an inference action.+--+-- The caller may modify the scope before invoking the action via+-- 'Hyper.Class.Infer.Env.localScopeType' or 'Hyper.Infer.ScopeLevel.localLevel'+newtype InferChild m h t =+    InferChild { inferChild :: m (InferredChild (UVarOf m) h t) }+makePrisms ''InferChild++-- | @Infer m t@ enables 'Hyper.Infer.infer' to perform type-inference for @t@ in the 'Monad' @m@.+--+-- The 'inferContext' method represents the following constraints on @t@:+--+-- * @HNodesConstraint (InferOf t) (Unify m)@ - The child nodes of the inferrence can unify in the @m@ 'Monad'+-- * @HNodesConstraint t (Infer m)@ - @Infer m@ is also available for child nodes+--+-- It replaces context for the 'Infer' class to avoid @UndecidableSuperClasses@.+--+-- Instances usually don't need to implement this method as the default implementation works for them,+-- but infinitely polymorphic trees such as 'Hyper.Type.AST.NamelessScope.Scope' do need to implement the method,+-- because the required context is infinite.+class (Monad m, HFunctor t) => Infer m t where+    -- | Infer the body of an expression given the inference actions for its child nodes.+    inferBody ::+        t # InferChild m h ->+        m (t # h, InferOf t # UVarOf m)+    default inferBody ::+        (Generic1 t, Infer m (Rep1 t), InferOf t ~ InferOf (Rep1 t)) =>+        t # InferChild m h ->+        m (t # h, InferOf t # UVarOf m)+    inferBody =+        fmap (Lens._1 %~ to1) . inferBody . from1++    -- TODO: Putting documentation here causes duplication in the haddock documentation+    inferContext ::+        proxy0 m ->+        proxy1 t ->+        Dict (HNodesConstraint t (Infer m), HNodesConstraint (InferOf t) (UnifyGen m))+    {-# INLINE inferContext #-}+    default inferContext ::+        (HNodesConstraint t (Infer m), HNodesConstraint (InferOf t) (UnifyGen m)) =>+        proxy0 m ->+        proxy1 t ->+        Dict (HNodesConstraint t (Infer m), HNodesConstraint (InferOf t) (UnifyGen m))+    inferContext _ _ = Dict++instance Recursive (Infer m) where+    {-# INLINE recurse #-}+    recurse p =+        withDict (inferContext (Proxy @m) (proxyArgument p)) Dict++type instance InferOf (a :+: _) = InferOf a++instance (InferOf a ~ InferOf b, Infer m a, Infer m b) => Infer m (a :+: b) where+    {-# INLINE inferBody #-}+    inferBody (L1 x) = inferBody x <&> Lens._1 %~ L1+    inferBody (R1 x) = inferBody x <&> Lens._1 %~ R1++    {-# INLINE inferContext #-}+    inferContext p _ =+        withDict (inferContext p (Proxy @a)) $+        withDict (inferContext p (Proxy @b)) Dict++type instance InferOf (M1 _ _ h) = InferOf h++instance Infer m h => Infer m (M1 i c h) where+    {-# INLINE inferBody #-}+    inferBody (M1 x) = inferBody x <&> Lens._1 %~ M1++    {-# INLINE inferContext #-}+    inferContext p _ = withDict (inferContext p (Proxy @h)) Dict++type instance InferOf (Rec1 h) = InferOf h++instance Infer m h => Infer m (Rec1 h) where+    {-# INLINE inferBody #-}+    inferBody (Rec1 x) = inferBody x <&> Lens._1 %~ Rec1++    {-# INLINE inferContext #-}+    inferContext p _ = withDict (inferContext p (Proxy @h)) Dict
+ src/Hyper/Class/Infer/Env.hs view
@@ -0,0 +1,15 @@+-- | Traits of inference monads.++module Hyper.Class.Infer.Env+    ( LocalScopeType(..)+    ) where++-- | @LocalScopeType var scheme m@ represents that+-- @m@ maintains a scope mapping variables of type @var@+-- to type schemes of type @scheme@.+--+-- Used by the 'Hyper.Class.Infer.Infer' instances+-- of 'Hyper.Type.AST.Lam.Lam' and 'Hyper.Type.AST.Let.Let'.+class LocalScopeType var scheme m where+    -- | Add a variable type into an action's scope+    localScopeType :: var -> scheme -> m a -> m a
+ src/Hyper/Class/Infer/InferOf.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}++module Hyper.Class.Infer.InferOf+    ( HasInferredType(..)+    , HasInferredValue(..)+    , InferOfConstraint(..), RTraversableInferOf+    ) where++import Control.Lens (ALens', Lens')+import Hyper.Class.Foldable (HFoldable)+import Hyper.Class.Functor (HFunctor)+import Hyper.Class.Infer (InferOf)+import Hyper.Class.Nodes (HNodes(..))+import Hyper.Class.Recursive (Recursive(..), Recursively, proxyArgument)+import Hyper.Class.Traversable (HTraversable)+import Hyper.Type (HyperType, type (#))++import Hyper.Internal.Prelude++-- | @HasInferredType t@ represents that @InferOf t@ contains a @TypeOf t@, which represents its inferred type.+class HasInferredType t where+    -- | The type of @t@+    type TypeOf t :: HyperType+    -- A 'Control.Lens.Lens' from an inference result to an inferred type+    inferredType :: Proxy t -> ALens' (InferOf t # v) (v # TypeOf t)++-- | @HasInferredValue t@ represents that @InferOf t@ contains an inferred value for @t@.+class HasInferredValue t where+    -- | A 'Control.Lens.Lens' from an inference result to an inferred value+    inferredValue :: Lens' (InferOf t # v) (v # t)++class InferOfConstraint c h where+    inferOfConstraint :: proxy0 c -> proxy1 h -> Dict (c (InferOf h))++instance c (InferOf h) => InferOfConstraint c h where+    inferOfConstraint _ _ = Dict++class+    (HTraversable (InferOf h), Recursively (InferOfConstraint HFunctor) h, Recursively (InferOfConstraint HFoldable) h) =>+    RTraversableInferOf h where+    rTraversableInferOfRec ::+        Proxy h -> Dict (HNodesConstraint h RTraversableInferOf)+    {-# INLINE rTraversableInferOfRec #-}+    default rTraversableInferOfRec ::+        HNodesConstraint h RTraversableInferOf =>+        Proxy h -> Dict (HNodesConstraint h RTraversableInferOf)+    rTraversableInferOfRec _ = Dict++instance Recursive RTraversableInferOf where+    {-# INLINE recurse #-}+    recurse = rTraversableInferOfRec . proxyArgument
+ src/Hyper/Class/Monad.hs view
@@ -0,0 +1,42 @@+-- | A variant of 'Control.Monad.Monad' for 'Hyper.Type.HyperType's++{-# LANGUAGE FlexibleContexts #-}++module Hyper.Class.Monad+    ( HMonad(..), hbind+    ) where++import Hyper.Class.Apply (HApplicative)+import Hyper.Class.Functor (HFunctor(..))+import Hyper.Class.Nodes (HWitness, (#>))+import Hyper.Class.Recursive (Recursively(..))+import Hyper.Combinator.Compose (HCompose, _HCompose)+import Hyper.Type (type (#))+import Hyper.Type.Pure (Pure(..), _Pure)++import Hyper.Internal.Prelude++-- | A variant of 'Control.Monad.Monad' for 'Hyper.Type.HyperType's+class HApplicative h => HMonad h where+    hjoin ::+        Recursively HFunctor p =>+        HCompose h h # p ->+        h # p++instance HMonad Pure where+    hjoin x =+        withDict (recursively (p x)) $+        _Pure #+        hmap (Proxy @(Recursively HFunctor) #> hjoin)+        (x ^. _HCompose . _Pure . _HCompose . _Pure . _HCompose)+        where+            p :: HCompose Pure Pure # p -> Proxy (HFunctor p)+            p _ = Proxy++-- | A variant of 'Control.Monad.(>>=)' for 'Hyper.Type.HyperType's+hbind ::+    (HMonad h, Recursively HFunctor p) =>+    h # p ->+    (forall n. HWitness h n -> p # n -> HCompose h p # n) ->+    h # p+hbind x f = _HCompose # hmap f x & hjoin
+ src/Hyper/Class/Morph.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleInstances #-}++-- | An extension of 'HFunctor' for parameterized 'Hyper.Type.HyperType's++module Hyper.Class.Morph+    ( HMorph(..), HMorphWithConstraint+    , morphTraverse, (#?>)+    , HIs2, morphMapped1, morphTraverse1+    ) where++import Control.Lens (Setter, sets)+import Data.Kind (Type)+import Hyper.Class.Traversable (HTraversable(..), ContainedH(..))+import Hyper.Type (type (#), HyperType)++import Hyper.Internal.Prelude++-- | A type-varying variant of 'HFunctor' which can modify type parameters of the mapped 'HyperType'+class HMorph s t where+    type MorphConstraint s t (c :: (HyperType -> HyperType -> Constraint)) :: Constraint++    data MorphWitness s t :: HyperType -> HyperType -> Type++    morphMap ::+        (forall a b. MorphWitness s t a b -> p # a -> q # b) ->+        s # p ->+        t # q++    morphLiftConstraint ::+        MorphConstraint s t c =>+        MorphWitness s t a b ->+        Proxy c ->+        (c a b => r) ->+        r++type HMorphWithConstraint s t c = (HMorph s t, MorphConstraint s t c)++-- | 'HTraversable' extended with support of changing type parameters of the 'HyperType'+morphTraverse ::+    (Applicative f, HMorph s t, HTraversable t) =>+    (forall a b. MorphWitness s t a b -> p # a -> f (q # b)) ->+    s # p ->+    f (t # q)+morphTraverse f = hsequence . morphMap (fmap MkContainedH . f)++(#?>) ::+    (HMorph s t, MorphConstraint s t c) =>+    Proxy c -> (c a b => r) -> MorphWitness s t a b -> r+(#?>) p r w = morphLiftConstraint w p r++class (i0 ~ t0, i1 ~ t1) => HIs2 (i0 :: HyperType) (i1 :: HyperType) t0 t1+instance HIs2 a b a b++morphMapped1 ::+    forall a b s t p q.+    HMorphWithConstraint s t (HIs2 a b) =>+    Setter (s # p) (t # q) (p # a) (q # b)+morphMapped1 = sets (\f -> morphMap (Proxy @(HIs2 a b) #?> f))++morphTraverse1 ::+    (HMorphWithConstraint s t (HIs2 a b), HTraversable t) =>+    Traversal (s # p) (t # q) (p # a) (q # b)+morphTraverse1 f = hsequence . (morphMapped1 %~ MkContainedH . f)
+ src/Hyper/Class/Nodes.hs view
@@ -0,0 +1,107 @@+-- | A class for witness types and lifting of constraints to the child nodes of a 'HyperType'++{-# LANGUAGE EmptyCase, UndecidableInstances, TemplateHaskell, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++module Hyper.Class.Nodes+    ( HNodes(..), HWitness(..), _HWitness+    , (#>), (#*#)+    , HNodesHaveConstraint(..)+    ) where++import Data.Kind (Type)+import GHC.Generics+import Hyper.Type++import Hyper.Internal.Prelude++newtype HWitness h n = HWitness (HWitnessType h n)++-- | 'HNodes' allows talking about the child nodes of a 'HyperType'.+--+-- Various classes like 'Hyper.Class.Functor.HFunctor' build upon 'HNodes'+-- to provide methods such as 'Hyper.Class.Functor.hmap' which provide a rank-n function+-- for processing child nodes which requires a constraint on the nodes.+class HNodes (h :: HyperType) where+    -- | Lift a constraint to apply to the child nodes+    type HNodesConstraint h (c :: (HyperType -> Constraint)) :: Constraint+    type instance HNodesConstraint h c = HNodesConstraint (Rep1 h) c++    -- | @HWitness h n@ is a witness that @n@ is a node of @h@.+    --+    -- A value quantified with @forall n. HWitness h n -> ... n@,+    -- is equivalent for a "for-some" where the possible values for @n@ are the nodes of @h@.+    type HWitnessType h :: HyperType -> Type+    type instance HWitnessType h = HWitnessType (Rep1 h)++    -- | Lift a rank-n value with a constraint which the child nodes satisfy+    -- to a function from a node witness.+    hLiftConstraint ::+        HNodesConstraint h c =>+        HWitness h n ->+        Proxy c ->+        (c n => r) ->+        r+    {-# INLINE hLiftConstraint #-}+    default hLiftConstraint ::+        ( HWitnessType h ~ HWitnessType (Rep1 h)+        , HNodesConstraint h c ~ HNodesConstraint (Rep1 h) c+        , HNodes (Rep1 h)+        , HNodesConstraint h c+        ) =>+        HWitness h n ->+        Proxy c ->+        (c n => r) ->+        r+    hLiftConstraint (HWitness w) = hLiftConstraint @(Rep1 h) (HWitness w)++makePrisms ''HWitness++instance HNodes (Const a) where+    type HNodesConstraint (Const a) _ = ()+    type HWitnessType (Const a) = V1+    {-# INLINE hLiftConstraint #-}+    hLiftConstraint = \case{}++instance (HNodes a, HNodes b) => HNodes (a :*: b) where+    type HNodesConstraint (a :*: b) x = (HNodesConstraint a x, HNodesConstraint b x)+    type HWitnessType (a :*: b) = HWitness a :+: HWitness b+    {-# INLINE hLiftConstraint #-}+    hLiftConstraint (HWitness (L1 w)) = hLiftConstraint w+    hLiftConstraint (HWitness (R1 w)) = hLiftConstraint w++instance (HNodes a, HNodes b) => HNodes (a :+: b) where+    type HNodesConstraint (a :+: b) x = (HNodesConstraint a x, HNodesConstraint b x)+    type HWitnessType (a :+: b) = HWitness a :+: HWitness b+    {-# INLINE hLiftConstraint #-}+    hLiftConstraint (HWitness (L1 w)) = hLiftConstraint w+    hLiftConstraint (HWitness (R1 w)) = hLiftConstraint w++deriving newtype instance HNodes h => HNodes (M1 i m h)+deriving newtype instance HNodes h => HNodes (Rec1 h)++infixr 0 #>+infixr 0 #*#++-- | @Proxy @c #> r@ replaces the witness parameter of @r@ with a constraint on the witnessed node+{-# INLINE (#>) #-}+(#>) ::+    (HNodes h, HNodesConstraint h c) =>+    Proxy c -> (c n => r) -> HWitness h n -> r+(#>) p r w = hLiftConstraint w p r++-- | A variant of '#>' which does not consume the witness parameter.+--+-- @Proxy @c0 #*# Proxy @c1 #> r@ brings into context both the @c0 n@ and @c1 n@ constraints.+{-# INLINE (#*#) #-}+(#*#) ::+    (HNodes h, HNodesConstraint h c) =>+    Proxy c -> (HWitness h n -> (c n => r)) -> HWitness h n -> r+(#*#) p r w = (p #> r) w w++-- | Defunctionalized HNodesConstraint which can be curried+class HNodesHaveConstraint c h where+    hNodesHaveConstraint :: proxy0 c -> proxy1 h -> Dict (HNodesConstraint h c)++instance HNodesConstraint h c => HNodesHaveConstraint c h where+    hNodesHaveConstraint _ _ = Dict
+ src/Hyper/Class/Optic.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE FlexibleContexts #-}++module Hyper.Class.Optic+    ( HNodeLens(..)+    , HSubset(..), HSubset'+    ) where++import Control.Lens (Lens', Prism)+import Hyper.Type (type (#))++class HNodeLens s a where+    hNodeLens :: Lens' (s # h) (h # a)++class HSubset s t a b where+    hSubset :: Prism (s # h) (t # h) (a # h) (b # h)++type HSubset' s a = HSubset s s a a
+ src/Hyper/Class/Pointed.hs view
@@ -0,0 +1,27 @@+-- | A variant of 'Data.Pointed.Pointed' for 'Hyper.Type.HyperType's++module Hyper.Class.Pointed+    ( HPointed(..)+    ) where++import GHC.Generics ((:+:)(..))+import Hyper.Class.Nodes (HNodes, HWitness(..))+import Hyper.Type (type (#))++import Hyper.Internal.Prelude++-- | A variant of 'Data.Pointed.Pointed' for 'Hyper.Type.HyperType's+class HNodes h => HPointed h where+    -- | Construct a value from a generator of @h@'s nodes+    -- (a generator which can generate a tree of any type given a witness that it is a node of @h@)+    hpure ::+        (forall n. HWitness h n -> p # n) ->+        h # p++instance Monoid a => HPointed (Const a) where+    {-# INLINE hpure #-}+    hpure _ = Const mempty++instance (HPointed a, HPointed b) => HPointed (a :*: b) where+    {-# INLINE hpure #-}+    hpure f = hpure (f . HWitness . L1) :*: hpure (f . HWitness . R1)
+ src/Hyper/Class/Recursive.hs view
@@ -0,0 +1,85 @@+-- | Classes applying on 'HyperType's recursively++{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}++module Hyper.Class.Recursive+    ( Recursive(..)+    , Recursively(..)+    , RNodes(..), RTraversable(..)+    , proxyArgument+    ) where++import Hyper.Class.Foldable+import Hyper.Class.Functor (HFunctor(..))+import Hyper.Class.Nodes (HNodes(..))+import Hyper.Class.Traversable+import Hyper.Type+import Hyper.Type.Pure (Pure(..))++import Hyper.Internal.Prelude++-- | A class of constraint constructors that apply to all recursive child nodes+class Recursive c where+    -- | Lift a recursive constraint to the next layer+    recurse :: (HNodes h, c h) => proxy (c h) -> Dict (HNodesConstraint h c)++-- | A class of 'HyperType's which recursively implement 'HNodes'+class HNodes h => RNodes h where+    recursiveHNodes :: proxy h -> Dict (HNodesConstraint h RNodes)+    {-# INLINE recursiveHNodes #-}+    default recursiveHNodes ::+        HNodesConstraint h RNodes =>+        proxy h -> Dict (HNodesConstraint h RNodes)+    recursiveHNodes _ = Dict++instance RNodes Pure+instance RNodes (Const a)++-- | Helper Proxy combinator that is useful in many instances of 'Recursive'+proxyArgument :: proxy (f h :: Constraint) -> Proxy (h :: HyperType)+proxyArgument _ = Proxy++instance Recursive RNodes where+    {-# INLINE recurse #-}+    recurse = recursiveHNodes . proxyArgument++-- | A constraint lifted to apply recursively.+--+-- Note that in cases where a constraint has dependencies other than 'RNodes',+-- one will want to create a class such as RTraversable to capture the dependencies,+-- otherwise using it in class contexts will be quite unergonomic.+class RNodes h => Recursively c h where+    recursively ::+        proxy (c h) -> Dict (c h, HNodesConstraint h (Recursively c))+    {-# INLINE recursively #-}+    default recursively ::+        (c h, HNodesConstraint h (Recursively c)) =>+        proxy (c h) -> Dict (c h, HNodesConstraint h (Recursively c))+    recursively _ = Dict++instance Recursive (Recursively c) where+    {-# INLINE recurse #-}+    recurse p =+        withDict (recursively (p0 p)) Dict+        where+            p0 :: proxy (Recursively c h) -> Proxy (c h)+            p0 _ = Proxy++instance c Pure => Recursively c Pure+instance c (Const a) => Recursively c (Const a)++-- | A class of 'HyperType's which recursively implement 'HTraversable'+class (HTraversable h, Recursively HFunctor h, Recursively HFoldable h) => RTraversable h where+    recursiveHTraversable :: proxy h -> Dict (HNodesConstraint h RTraversable)+    {-# INLINE recursiveHTraversable #-}+    default recursiveHTraversable ::+        HNodesConstraint h RTraversable =>+        proxy h -> Dict (HNodesConstraint h RTraversable)+    recursiveHTraversable _ = Dict++instance RTraversable Pure+instance RTraversable (Const a)++instance Recursive RTraversable where+    {-# INLINE recurse #-}+    recurse = recursiveHTraversable . proxyArgument
+ src/Hyper/Class/Traversable.hs view
@@ -0,0 +1,86 @@+-- | A variant of 'Traversable' for 'Hyper.Type.HyperType's++{-# LANGUAGE FlexibleContexts #-}++module Hyper.Class.Traversable+    ( HTraversable(..)+    , ContainedH(..), _ContainedH+    , htraverse, htraverse1+    ) where++import Control.Lens (iso)+import GHC.Generics+import GHC.Generics.Lens (_M1, _Rec1)+import Hyper.Class.Foldable (HFoldable)+import Hyper.Class.Functor (HFunctor(..), hmapped1)+import Hyper.Class.Nodes (HNodes(..), HWitness)+import Hyper.Type (AHyperType, type (#))++import Hyper.Internal.Prelude++-- | A 'Hyper.Type.HyperType' containing a tree inside an action.+--+-- Used to express 'hsequence'.+newtype ContainedH f p (h :: AHyperType) = MkContainedH { runContainedH :: f (p h) }++-- | An 'Iso' for the 'ContainedH' @newtype@+{-# INLINE _ContainedH #-}+_ContainedH ::+    Iso (ContainedH f0 p0 # k0)+        (ContainedH f1 p1 # k1)+        (f0 (p0 # k0))+        (f1 (p1 # k1))+_ContainedH = iso runContainedH MkContainedH++-- | A variant of 'Traversable' for 'Hyper.Type.HyperType's+class (HFunctor h, HFoldable h) => HTraversable h where+    -- | 'HTraversable' variant of 'sequenceA'+    hsequence ::+        Applicative f =>+        h # ContainedH f p ->+        f (h # p)+    {-# INLINE hsequence #-}+    default hsequence ::+        (Generic1 h, HTraversable (Rep1 h), Applicative f) =>+        h # ContainedH f p ->+        f (h # p)+    hsequence = fmap to1 . hsequence . from1++instance HTraversable (Const a) where+    {-# INLINE hsequence #-}+    hsequence (Const x) = pure (Const x)++instance (HTraversable a, HTraversable b) => HTraversable (a :*: b) where+    {-# INLINE hsequence #-}+    hsequence (x :*: y) = (:*:) <$> hsequence x <*> hsequence y++instance (HTraversable a, HTraversable b) => HTraversable (a :+: b) where+    {-# INLINE hsequence #-}+    hsequence (L1 x) = hsequence x <&> L1+    hsequence (R1 x) = hsequence x <&> R1++instance HTraversable h => HTraversable (M1 i m h) where+    {-# INLINE hsequence #-}+    hsequence = _M1 hsequence++instance HTraversable h => HTraversable (Rec1 h) where+    {-# INLINE hsequence #-}+    hsequence = _Rec1 hsequence++-- | 'HTraversable' variant of 'traverse'+{-# INLINE htraverse #-}+htraverse ::+    (Applicative f, HTraversable h) =>+    (forall n. HWitness h n -> p # n -> f (q # n)) ->+    h # p ->+    f (h # q)+htraverse f = hsequence . hmap (fmap MkContainedH . f)++-- | 'HTraversable' variant of 'traverse' for 'Hyper.Type.HyperType's with a single node type.+--+-- It is a valid 'Traversal' as it avoids using @RankNTypes@.+{-# INLINE htraverse1 #-}+htraverse1 ::+    (HTraversable h, HNodesConstraint h ((~) n)) =>+    Traversal (h # p) (h # q) (p # n) (q # n)+htraverse1 f = hsequence . (hmapped1 %~ MkContainedH . f)
+ src/Hyper/Class/Unify.hs view
@@ -0,0 +1,195 @@+-- | A class for unification++{-# LANGUAGE FlexibleContexts #-}++module Hyper.Class.Unify+    ( Unify(..), UVarOf+    , UnifyGen(..)+    , BindingDict(..)+    , applyBindings, semiPruneLookup, occursError+    ) where++import Control.Monad (unless)+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.State (runStateT, get, put)+import Data.Kind (Type)+import Hyper.Class.Nodes (HNodes(..), (#>))+import Hyper.Class.Optic (HSubset(..), HSubset')+import Hyper.Class.Recursive+import Hyper.Class.Traversable (htraverse)+import Hyper.Class.ZipMatch (ZipMatch)+import Hyper.Type (HyperType, type (#))+import Hyper.Type.Pure (Pure, _Pure)+import Hyper.Unify.Constraints+import Hyper.Unify.Error (UnifyError(..))+import Hyper.Unify.QuantifiedVar (MonadQuantify(..), HasQuantifiedVar(..))+import Hyper.Unify.Term (UTerm(..), UTermBody(..), uBody)++import Hyper.Internal.Prelude++-- | Unification variable type for a unification monad+type family UVarOf (m :: Type -> Type) :: HyperType++-- | BindingDict implements unification variables for a type in a unification monad.+--+-- It is parameterized on:+--+-- * @v@: The unification variable 'HyperType'+-- * @m@: The 'Monad' to bind in+-- * @t@: The unified term's 'HyperType'+--+-- Has 2 implementations in hypertypes:+--+-- * 'Hyper.Unify.Binding.bindingDict' for pure state based unification+-- * 'Hyper.Unify.Binding.ST.stBinding' for 'Control.Monad.ST.ST' based unification+data BindingDict v m t = BindingDict+    { lookupVar :: !(v # t -> m (UTerm v # t))+    , newVar :: !(UTerm v # t -> m (v # t))+    , bindVar :: !(v # t -> UTerm v # t -> m ())+    }++-- | @Unify m t@ enables 'Hyper.Unify.unify' to perform unification for @t@ in the 'Monad' @m@.+--+-- The 'unifyRecursive' method represents the constraint that @Unify m@ applies to all recursive child nodes.+-- It replaces context for 'Unify' to avoid @UndecidableSuperClasses@.+class+    ( Eq (UVarOf m # t)+    , RTraversable t+    , ZipMatch t+    , HasTypeConstraints t+    , HasQuantifiedVar t+    , Monad m+    , MonadQuantify (TypeConstraintsOf t) (QVar t) m+    ) => Unify m t where++    -- | The implementation for unification variables binding and lookup+    binding :: BindingDict (UVarOf m) m t++    -- | Handles a unification error.+    --+    -- If 'unifyError' is called then unification has failed.+    -- A compiler implementation may present an error message based on the provided 'UnifyError' when this occurs.+    unifyError :: UnifyError t # UVarOf m -> m a+    default unifyError ::+        (MonadError (e # Pure) m, HSubset' e (UnifyError t)) =>+        UnifyError t # UVarOf m -> m a+    unifyError e =+        withDict (unifyRecursive (Proxy @m) (Proxy @t)) $+        htraverse (Proxy @(Unify m) #> applyBindings) e+        >>= throwError . (hSubset #)++    -- | What to do when top-levels of terms being unified do not match.+    --+    -- Usually this will cause a 'unifyError'.+    --+    -- Some AST terms could be equivalent despite not matching structurally,+    -- like record field extentions with the fields ordered differently.+    -- Those would override the default implementation to handle the unification of mismatching structures.+    structureMismatch ::+        (forall c. Unify m c => UVarOf m # c -> UVarOf m # c -> m (UVarOf m # c)) ->+        t # UVarOf m -> t # UVarOf m -> m ()+    structureMismatch _ x y = unifyError (Mismatch x y)++    -- TODO: Putting documentation here causes duplication in the haddock documentation+    unifyRecursive :: Proxy m -> Proxy t -> Dict (HNodesConstraint t (Unify m))+    {-# INLINE unifyRecursive #-}+    default unifyRecursive ::+        HNodesConstraint t (Unify m) =>+        Proxy m -> Proxy t -> Dict (HNodesConstraint t (Unify m))+    unifyRecursive _ _ = Dict++instance Recursive (Unify m) where+    {-# INLINE recurse #-}+    recurse = unifyRecursive (Proxy @m) . proxyArgument++-- | A class for unification monads with scope levels+class Unify m t => UnifyGen m t where+    -- | Get the current scope constraint+    scopeConstraints :: Proxy t -> m (TypeConstraintsOf t)++    unifyGenRecursive :: Proxy m -> Proxy t -> Dict (HNodesConstraint t (UnifyGen m))+    {-# INLINE unifyGenRecursive #-}+    default unifyGenRecursive ::+        HNodesConstraint t (UnifyGen m) =>+        Proxy m -> Proxy t -> Dict (HNodesConstraint t (UnifyGen m))+    unifyGenRecursive _ _ = Dict++instance Recursive (UnifyGen m) where+    {-# INLINE recurse #-}+    recurse = unifyGenRecursive (Proxy @m) . proxyArgument++-- | Look up a variable, and return last variable pointing to result.+-- Prunes all variables on way to point to the last variable+-- (path-compression ala union-find).+{-# INLINE semiPruneLookup #-}+semiPruneLookup ::+    Unify m t =>+    UVarOf m # t ->+    m (UVarOf m # t, UTerm (UVarOf m) # t)+semiPruneLookup v0 =+    lookupVar binding v0+    >>=+    \case+    UToVar v1 ->+        do+            (v, r) <- semiPruneLookup v1+            bindVar binding v0 (UToVar v)+            pure (v, r)+    t -> pure (v0, t)++-- | Resolve a term from a unification variable.+--+-- Note that this must be done after+-- all unifications involving the term and its children are done,+-- as it replaces unification state with cached resolved terms.+{-# INLINE applyBindings #-}+applyBindings ::+    forall m t.+    Unify m t =>+    UVarOf m # t ->+    m (Pure # t)+applyBindings v0 =+    semiPruneLookup v0+    >>=+    \(v1, x) ->+    let result r = r <$ bindVar binding v1 (UResolved r)+        quantify c =+            newQuantifiedVariable c <&> (_Pure . quantifiedVar #)+            >>= result+    in+    case x of+    UResolving t -> occursError v1 t+    UResolved t -> pure t+    UUnbound c -> quantify c+    USkolem c -> quantify c+    UTerm b ->+        do+            (r, anyChild) <-+                withDict (unifyRecursive (Proxy @m) (Proxy @t)) $+                htraverse+                ( Proxy @(Unify m) #>+                    \c ->+                    do+                        get >>= lift . (`unless` bindVar binding v1 (UResolving b))+                        put True+                        applyBindings c & lift+                ) (b ^. uBody)+                & (`runStateT` False)+            _Pure # r & if anyChild then result else pure+    UToVar{} -> error "lookup not expected to result in var"+    UConverted{} -> error "conversion state not expected in applyBindings"+    UInstantiated{} ->+        -- This can happen in alphaEq,+        -- where UInstantiated marks that var from one side matches var in the other.+        quantify mempty++-- | Format and throw an occurs check error+occursError ::+    Unify m t =>+    UVarOf m # t -> UTermBody (UVarOf m) # t -> m a+occursError v (UTermBody c b) =+    do+        q <- newQuantifiedVariable c+        bindVar binding v (UResolved (_Pure . quantifiedVar # q))+        unifyError (Occurs (quantifiedVar # q) b)
+ src/Hyper/Class/ZipMatch.hs view
@@ -0,0 +1,96 @@+-- | A class to match term structures++{-# LANGUAGE FlexibleContexts #-}++module Hyper.Class.ZipMatch+    ( ZipMatch(..)+    , zipMatch2+    , zipMatchA+    , zipMatch_, zipMatch1_+    ) where++import GHC.Generics+import Hyper.Class.Foldable (HFoldable, htraverse_, htraverse1_)+import Hyper.Class.Functor (HFunctor(..))+import Hyper.Class.Nodes (HNodes(..), HWitness)+import Hyper.Class.Traversable (HTraversable, htraverse)+import Hyper.Type (type (#))+import Hyper.Type.Pure (Pure(..), _Pure)++import Hyper.Internal.Prelude++-- | A class to match term structures.+--+-- Similar to a partial version of 'Hyper.Class.Apply.Apply' but the semantics are different -+-- when the terms contain plain values, 'Hyper.Class.Apply.hzip' would append them,+-- but 'zipMatch' would compare them and only produce a result if they match.+--+-- The @TemplateHaskell@ generators 'Hyper.TH.Apply.makeHApply' and 'Hyper.TH.ZipMatch.makeZipMatch'+-- create the instances according to these semantics.+class ZipMatch h where+    -- | Compare two structures+    --+    -- >>> zipMatch (NewPerson p0) (NewPerson p1)+    -- Just (NewPerson (Pair p0 p1))+    -- >>> zipMatch (NewPerson p) (NewCake c)+    -- Nothing+    zipMatch :: h # p -> h # q -> Maybe (h # (p :*: q))+    default zipMatch ::+        (Generic1 h, ZipMatch (Rep1 h)) =>+        h # p -> h # q -> Maybe (h # (p :*: q))+    zipMatch x =+        fmap to1 . zipMatch (from1 x) . from1++instance ZipMatch Pure where+    {-# INLINE zipMatch #-}+    zipMatch (Pure x) (Pure y) = _Pure # (x :*: y) & Just++instance Eq a => ZipMatch (Const a) where+    {-# INLINE zipMatch #-}+    zipMatch (Const x) (Const y) = Const x <$ guard (x == y)++instance (ZipMatch a, ZipMatch b) => ZipMatch (a :*: b) where+    {-# INLINE zipMatch #-}+    zipMatch (a0 :*: b0) (a1 :*: b1) = (:*:) <$> zipMatch a0 a1 <*> zipMatch b0 b1++instance (ZipMatch a, ZipMatch b) => ZipMatch (a :+: b) where+    {-# INLINE zipMatch #-}+    zipMatch (L1 x) (L1 y) = zipMatch x y <&> L1+    zipMatch (R1 x) (R1 y) = zipMatch x y <&> R1+    zipMatch L1{} R1{} = Nothing+    zipMatch R1{} L1{} = Nothing++deriving newtype instance ZipMatch h => ZipMatch (M1 i m h)+deriving newtype instance ZipMatch h => ZipMatch (Rec1 h)++-- | 'ZipMatch' variant of 'Control.Applicative.liftA2'+{-# INLINE zipMatch2 #-}+zipMatch2 ::+    (ZipMatch h, HFunctor h) =>+    (forall n. HWitness h n -> p # n -> q # n -> r # n) ->+    h # p -> h # q -> Maybe (h # r)+zipMatch2 f x y = zipMatch x y <&> hmap (\w (a :*: b) -> f w a b)++-- | An 'Applicative' variant of 'zipMatch2'+{-# INLINE zipMatchA #-}+zipMatchA ::+    (Applicative f, ZipMatch h, HTraversable h) =>+    (forall n. HWitness h n -> p # n -> q # n -> f (r # n)) ->+    h # p -> h # q -> Maybe (f (h # r))+zipMatchA f x y = zipMatch x y <&> htraverse (\w (a :*: b) -> f w a b)++-- | A variant of 'zipMatchA' where the 'Applicative' actions do not contain results+{-# INLINE zipMatch_ #-}+zipMatch_ ::+    (Applicative f, ZipMatch h, HFoldable h) =>+    (forall n. HWitness h n -> p # n -> q # n -> f ()) ->+    h # p -> h # q -> Maybe (f ())+zipMatch_ f x y = zipMatch x y <&> htraverse_ (\w (a :*: b) -> f w a b)++-- | A variant of 'zipMatch_' for 'Hyper.Type.HyperType's with a single node type (avoids using @RankNTypes@)+{-# INLINE zipMatch1_ #-}+zipMatch1_ ::+    (Applicative f, ZipMatch h, HFoldable h, HNodesConstraint h ((~) n)) =>+    (p # n -> q # n -> f ()) ->+    h # p -> h # q -> Maybe (f ())+zipMatch1_ f x y = zipMatch x y <&> htraverse1_ (\(a :*: b) -> f a b)
+ src/Hyper/Combinator/ANode.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE UndecidableInstances, TemplateHaskell, FlexibleInstances #-}++-- | A simple 'Hyper.Type.HyperType' with a single child node++module Hyper.Combinator.ANode+    ( ANode(..), _ANode, W_ANode(..), MorphWitness(..)+    ) where++import Control.Lens (iso)+import Hyper.Class.Optic (HNodeLens(..))+import Hyper.Class.Morph (HMorph(..))+import Hyper.Class.Recursive (RNodes, Recursively, RTraversable)+import Hyper.TH.Traversable (makeHTraversableApplyAndBases)+import Hyper.Type (type (#), type (:#))++import Hyper.Internal.Prelude++-- | @ANode c@ is a 'Hyper.Type.HyperType' with a single child node of type @c@+newtype ANode c h = MkANode (h :# c)+    deriving stock Generic++-- | An 'Iso' from 'ANode' its child node.+--+-- Using `_ANode` rather than the 'MkANode' data constructor is recommended,+-- because it helps the type inference know that @ANode c@ is parameterized with a 'Hyper.Type.HyperType'.+{-# INLINE _ANode #-}+_ANode :: Iso (ANode c0 # k0) (ANode c1 # k1) (k0 # c0) (k1 # c1)+_ANode = iso (\(MkANode x) -> x) MkANode++makeHTraversableApplyAndBases ''ANode+makeCommonInstances [''ANode]++instance HNodeLens (ANode c) c where hNodeLens = _ANode++instance RNodes n => RNodes (ANode n)+instance (c (ANode n), Recursively c n) => Recursively c (ANode n)+instance RTraversable n => RTraversable (ANode n)++instance HMorph (ANode a) (ANode b) where+    type instance MorphConstraint (ANode a) (ANode b) c = c a b+    data instance MorphWitness (ANode a) (ANode b) _ _ where+        M_ANode :: MorphWitness (ANode a) (ANode b) a b+    morphMap f = _ANode %~ f M_ANode+    morphLiftConstraint M_ANode _ = id
+ src/Hyper/Combinator/Ann.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE TemplateHaskell, UndecidableInstances, FlexibleInstances #-}++module Hyper.Combinator.Ann+    ( Ann(..), hAnn, hVal+    , Annotated, annotation, annValue+    ) where++import Control.Lens (Lens, Lens', _Wrapped, from)+import Hyper.Class.Foldable (HFoldable(..))+import Hyper.Class.Functor (HFunctor(..))+import Hyper.Class.Nodes+import Hyper.Class.Traversable+import Hyper.Combinator.Flip+import Hyper.Recurse+import Hyper.TH.Traversable (makeHTraversableApplyAndBases)+import Hyper.Type (type (#), type (:#))++import Hyper.Internal.Prelude++data Ann a h = Ann+    { _hAnn :: a h+    , _hVal :: h :# Ann a+    } deriving Generic+makeLenses ''Ann++makeHTraversableApplyAndBases ''Ann+makeCommonInstances [''Ann]++instance RNodes h => HNodes (HFlip Ann h) where+    type HNodesConstraint (HFlip Ann h) c = (Recursive c, c h)+    type HWitnessType (HFlip Ann h) = HRecWitness h+    hLiftConstraint (HWitness HRecSelf) = const id+    hLiftConstraint (HWitness (HRecSub w0 w1)) = hLiftConstraintH w0 w1++-- TODO: Dedup this and similar code in Hyper.Unify.Generalize+hLiftConstraintH ::+    forall a c b n r.+    (RNodes a, HNodesConstraint (HFlip Ann a) c) =>+    HWitness a b -> HRecWitness b n -> Proxy c -> (c n => r) -> r+hLiftConstraintH c n p f =+    withDict (recurse (Proxy @(RNodes a))) $+    withDict (recurse (Proxy @(c a))) $+    hLiftConstraint c (Proxy @RNodes)+    ( hLiftConstraint c p+        (hLiftConstraint (HWitness @(HFlip Ann _) n) p f)+    )++instance RNodes a => RNodes (Ann a) where+    {-# INLINE recursiveHNodes #-}+    recursiveHNodes _ = withDict (recursiveHNodes (Proxy @a)) Dict++instance (c (Ann a), Recursively c a) => Recursively c (Ann a) where+    {-# INLINE recursively #-}+    recursively _ = withDict (recursively (Proxy @(c a))) Dict++instance RTraversable a => RTraversable (Ann a) where+    {-# INLINE recursiveHTraversable #-}+    recursiveHTraversable _ = withDict (recursiveHTraversable (Proxy @a)) Dict++instance Recursively HFunctor h => HFunctor (HFlip Ann h) where+    {-# INLINE hmap #-}+    hmap f =+        withDict (recursively (Proxy @(HFunctor h))) $+        _HFlip %~+        \(Ann a b) ->+        Ann+        (f (HWitness HRecSelf) a)+        (hmap+            ( Proxy @(Recursively HFunctor) #*#+                \w -> from _HFlip %~ hmap (f . HWitness . HRecSub w . (^. _HWitness))+            ) b+        )++instance Recursively HFoldable h => HFoldable (HFlip Ann h) where+    {-# INLINE hfoldMap #-}+    hfoldMap f (MkHFlip (Ann a b)) =+        withDict (recursively (Proxy @(HFoldable h))) $+        f (HWitness HRecSelf) a <>+        hfoldMap+        ( Proxy @(Recursively HFoldable) #*#+            \w -> hfoldMap (f . HWitness . HRecSub w . (^. _HWitness)) . MkHFlip+        ) b++instance RTraversable h => HTraversable (HFlip Ann h) where+    {-# INLINE hsequence #-}+    hsequence =+        withDict (recurse (Proxy @(RTraversable h))) $+        _HFlip+        ( \(Ann a b) ->+            Ann+            <$> runContainedH a+            <*> htraverse (Proxy @RTraversable #> from _HFlip hsequence) b+        )++type Annotated a = Ann (Const a)++annotation :: Lens' (Annotated a # h) a+annotation = hAnn . _Wrapped++-- | Polymorphic lens to an @Annotated@ value+annValue :: Lens (Annotated a # h0) (Annotated a # h1) (h0 # Annotated a) (h1 # Annotated a)+annValue f (Ann (Const a) b) = f b <&> Ann (Const a)
+ src/Hyper/Combinator/Compose.hs view
@@ -0,0 +1,197 @@+-- | Compose two 'HyperType's.+--+-- Inspired by [hyperfunctions' @Category@ instance](http://hackage.haskell.org/package/hyperfunctions-0/docs/Control-Monad-Hyper.html).++{-# LANGUAGE UndecidableInstances, FlexibleInstances, FlexibleContexts, TemplateHaskell #-}++module Hyper.Combinator.Compose+    ( HCompose(..), _HCompose, W_HCompose(..)+    , HComposeConstraint1+    , decompose, decompose', hcomposed+    ) where++import Control.Lens (Profunctor, Optic, Iso', iso)+import Hyper.Class.Apply (HApply(..))+import Hyper.Class.Foldable (HFoldable(..))+import Hyper.Class.Functor (HFunctor(..), hiso)+import Hyper.Class.Nodes (HNodes(..), HWitness(..), (#>))+import Hyper.Class.Pointed (HPointed(..))+import Hyper.Class.Traversable (HTraversable(..), ContainedH(..), htraverse)+import Hyper.Class.Recursive (RNodes(..), Recursively(..), RTraversable)+import Hyper.Class.ZipMatch (ZipMatch(..))+import Hyper.Type (HyperType, GetHyperType, type (#))+import Hyper.Type.Pure (Pure, _Pure)++import Hyper.Internal.Prelude++-- | Compose two 'HyperType's as an external and internal layer+newtype HCompose a b h = HCompose { getHCompose :: a # HCompose b (GetHyperType h) }+    deriving stock Generic++makeCommonInstances [''HCompose]++-- | An 'Control.Lens.Iso' for the 'HCompose' @newtype@+{-# INLINE _HCompose #-}+_HCompose ::+    Iso+    (HCompose a0 b0 # h0) (HCompose a1 b1 # h1)+    (a0 # HCompose b0 h0) (a1 # HCompose b1 h1)+_HCompose = iso getHCompose HCompose++{-# ANN module "HLint: ignore Use camelCase" #-}+data W_HCompose a b n where+    W_HCompose :: HWitness a a0 -> HWitness b b0 -> W_HCompose a b (HCompose a0 b0)++instance (HNodes a, HNodes b) => HNodes (HCompose a b) where+    type HNodesConstraint (HCompose a b) c = HNodesConstraint a (HComposeConstraint0 c b)+    type HWitnessType (HCompose a b) = W_HCompose a b+    {-# INLINE hLiftConstraint #-}+    hLiftConstraint (HWitness (W_HCompose w0 w1)) p r =+        hLiftConstraint w0 (p0 p) $+        withDict (hComposeConstraint0 p (Proxy @b) w0) $+        hLiftConstraint w1 (p1 p w0) $+        withDict (d0 p w0 w1) r+        where+            p0 :: Proxy c -> Proxy (HComposeConstraint0 c b)+            p0 _ = Proxy+            p1 :: proxy0 c -> proxy1 a0 -> Proxy (HComposeConstraint1 c a0)+            p1 _ _ = Proxy+            d0 ::+                HComposeConstraint1 c a0 b0 =>+                Proxy c -> HWitness a a0 -> HWitness b b0 -> Dict (c (HCompose a0 b0))+            d0 _ _ _ = hComposeConstraint1++class HComposeConstraint0 (c :: HyperType -> Constraint) (b :: HyperType) (h0 :: HyperType) where+    hComposeConstraint0 ::+        proxy0 c -> proxy1 b -> proxy2 h0 ->+        Dict (HNodesConstraint b (HComposeConstraint1 c h0))++instance HNodesConstraint b (HComposeConstraint1 c h0) => HComposeConstraint0 c b h0 where+    {-# INLINE hComposeConstraint0 #-}+    hComposeConstraint0 _ _ _ = Dict++class HComposeConstraint1 (c :: HyperType -> Constraint) (h0 :: HyperType) (h1 :: HyperType) where+    hComposeConstraint1 :: Dict (c (HCompose h0 h1))++instance c (HCompose h0 h1) => HComposeConstraint1 c h0 h1 where+    {-# INLINE hComposeConstraint1 #-}+    hComposeConstraint1 = Dict++instance+    (HNodes a, HPointed a, HPointed b) =>+    HPointed (HCompose a b) where+    {-# INLINE hpure #-}+    hpure x =+        _HCompose #+        hpure+        ( \wa ->+            _HCompose # hpure (\wb -> _HCompose # x (HWitness (W_HCompose wa wb)))+        )++instance (HFunctor a, HFunctor b) => HFunctor (HCompose a b) where+    {-# INLINE hmap #-}+    hmap f =+        _HCompose %~+        hmap+        ( \w0 ->+            _HCompose %~ hmap (\w1 -> _HCompose %~ f (HWitness (W_HCompose w0 w1)))+        )++instance (HApply a, HApply b) => HApply (HCompose a b) where+    {-# INLINE hzip #-}+    hzip (HCompose a0) =+        _HCompose %~+        hmap+        ( \_ (HCompose b0 :*: HCompose b1) ->+            _HCompose #+            hmap+            ( \_ (HCompose i0 :*: HCompose i1) ->+                _HCompose # (i0 :*: i1)+            ) (hzip b0 b1)+        )+        . hzip a0++instance (HFoldable a, HFoldable b) => HFoldable (HCompose a b) where+    {-# INLINE hfoldMap #-}+    hfoldMap f =+        hfoldMap+        ( \w0 ->+            hfoldMap (\w1 -> f (HWitness (W_HCompose w0 w1)) . (^. _HCompose)) . (^. _HCompose)+        ) . (^. _HCompose)++instance (HTraversable a, HTraversable b) => HTraversable (HCompose a b) where+    {-# INLINE hsequence #-}+    hsequence =+        _HCompose+        ( hsequence .+            hmap (const (MkContainedH . _HCompose (htraverse (const (_HCompose runContainedH)))))+        )++instance+    (ZipMatch h0, ZipMatch h1, HTraversable h0, HFunctor h1) =>+    ZipMatch (HCompose h0 h1) where+    {-# INLINE zipMatch #-}+    zipMatch (HCompose x) (HCompose y) =+        zipMatch x y+        >>= htraverse+            (\_ (HCompose cx :*: HCompose cy) ->+                zipMatch cx cy+                <&> hmap+                    (\_ (HCompose bx :*: HCompose by) -> bx :*: by & HCompose)+                <&> (_HCompose #)+            )+        <&> (_HCompose #)++instance+    ( HNodes a, HNodes b+    , HNodesConstraint a (HComposeConstraint0 RNodes b)+    ) => RNodes (HCompose a b)++instance+    ( HNodes h0, HNodes h1+    , c (HCompose h0 h1)+    , HNodesConstraint h0 (HComposeConstraint0 RNodes h1)+    , HNodesConstraint h0 (HComposeConstraint0 (Recursively c) h1)+    ) => Recursively c (HCompose h0 h1)++instance+    ( HTraversable a, HTraversable b+    , HNodesConstraint a (HComposeConstraint0 RNodes b)+    , HNodesConstraint a (HComposeConstraint0 (Recursively HFunctor) b)+    , HNodesConstraint a (HComposeConstraint0 (Recursively HFoldable) b)+    , HNodesConstraint a (HComposeConstraint0 RTraversable b)+    ) => RTraversable (HCompose a b)++hcomposed ::+    (Profunctor p, Functor f) =>+    Optic p f+        (a0 # HCompose b0 c0)+        (a1 # HCompose b1 c1)+        (HCompose a2 b2 # c2)+        (HCompose a3 b3 # c3) ->+    Optic p f+        (HCompose a0 b0 # c0)+        (HCompose a1 b1 # c1)+        (a2 # HCompose b2 c2)+        (a3 # HCompose b3 c3)+hcomposed f = _HCompose . f . _HCompose++-- | Inject Pure between two hypertypes.+decompose ::+    forall a0 b0 a1 b1.+    (Recursively HFunctor a0, Recursively HFunctor b0, Recursively HFunctor a1, Recursively HFunctor b1) =>+    Iso (Pure # HCompose a0 b0) (Pure # HCompose a1 b1) (a0 # b0) (a1 # b1)+decompose = iso (^. decompose') (decompose' #)++decompose' ::+    forall a b.+    (Recursively HFunctor a, Recursively HFunctor b) =>+    Iso' (Pure # HCompose a b) (a # b)+decompose' =+    withDict (recursively (Proxy @(HFunctor a))) $+    withDict (recursively (Proxy @(HFunctor b))) $+    _Pure . _HCompose .+    hiso+    ( Proxy @(Recursively HFunctor) #>+        _HCompose . hiso ( Proxy @(Recursively HFunctor) #> _HCompose . decompose')+    )
+ src/Hyper/Combinator/Flip.hs view
@@ -0,0 +1,55 @@+-- | A combinator to flip the order of the last two type parameters of a 'Hyper.Type.HyperType'.++{-# LANGUAGE TemplateHaskell, UndecidableInstances, FlexibleContexts #-}++module Hyper.Combinator.Flip+    ( HFlip(..), _HFlip+    , hflipped+    , htraverseFlipped+    ) where++import Control.Lens (iso, from)+import Hyper.Class.Nodes (HWitness)+import Hyper.Class.Traversable (HTraversable, htraverse)+import Hyper.Type (type (#), GetHyperType)++import Hyper.Internal.Prelude++-- | Flip the order of the last two type parameters of a 'Hyper.Type.HyperType'.+--+-- Useful to use instances of classes such as 'Hyper.Class.Traversable.HTraversable' which+-- are available on the flipped 'Hyper.Type.HyperType'.+-- For example 'Hyper.Unify.Generalize.GTerm' has instances when flipped.+newtype HFlip f x h =+    MkHFlip (f (GetHyperType h) # x)+    deriving stock Generic++makeCommonInstances [''HFlip]++-- | An 'Iso' from 'Flip' to its content.+--+-- Using `_Flip` rather than the 'MkFlip' data constructor is recommended,+-- because it helps the type inference know that @ANode c@ is parameterized with a 'Hyper.Type.HyperType'.+_HFlip ::+    Iso+    (HFlip f0 x0 # k0)+    (HFlip f1 x1 # k1)+    (f0 k0 # x0)+    (f1 k1 # x1)+_HFlip = iso (\(MkHFlip x) -> x) MkHFlip++hflipped ::+    Iso+    (f0 k0 # x0)+    (f1 k1 # x1)+    (HFlip f0 x0 # k0)+    (HFlip f1 x1 # k1)+hflipped = from _HFlip++-- | Convinience function for traversal over second last 'HyperType' argument.+htraverseFlipped ::+    (Applicative f, HTraversable (HFlip h a)) =>+    (forall n. HWitness (HFlip h a) n -> p # n -> f (q # n)) ->+    h p # a ->+    f (h q # a)+htraverseFlipped f = hflipped (htraverse f)
+ src/Hyper/Combinator/Func.hs view
@@ -0,0 +1,15 @@+module Hyper.Combinator.Func+    ( HFunc(..), _HFunc+    ) where++import Control.Lens (Iso, iso)+import Hyper.Type (HyperType, type (#))++newtype HFunc (i :: HyperType) o h = HFunc (i h -> o h)++_HFunc ::+    Iso (HFunc i0 o0 # h0)+        (HFunc i1 o1 # h1)+        (i0 # h0 -> o0 # h0)+        (i1 # h1 -> o1 # h1)+_HFunc = iso (\(HFunc x) -> x) HFunc
+ src/Hyper/Diff.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE TemplateHaskell, FlexibleContexts, UndecidableInstances #-}++module Hyper.Diff+    ( diff+    , Diff(..), _CommonBody, _CommonSubTree, _Different+    , CommonBody(..), anns, val+    , foldDiffs++    , diffP+    , DiffP(..), _CommonBodyP, _CommonSubTreeP, _DifferentP+    , foldDiffsP+    ) where++import Hyper+import Hyper.Class.ZipMatch (ZipMatch(..))+import Hyper.Internal.Prelude+import Hyper.Recurse++-- | A 'HyperType' which represents the difference between two annotated trees.+-- The annotation types also function as tokens+-- to describe which of the two trees a term comes from.+data Diff a b e+    = CommonSubTree (Ann (a :*: b) e)+    | CommonBody (CommonBody a b e)+    | Different ((Ann a :*: Ann b) e)+    deriving Generic++-- | A 'HyperType' which represents two trees which have the same top-level node,+-- but their children may differ.+data CommonBody a b e = MkCommonBody+    { _anns :: (a :*: b) e+    , _val :: e :# Diff a b+    } deriving Generic++makePrisms ''Diff+makeLenses ''CommonBody++-- | Compute the difference of two annotated trees.+diff ::+    forall t a b.+    (Recursively ZipMatch t, RTraversable t) =>+    Ann a # t -> Ann b # t -> Diff a b # t+diff x@(Ann xA xB) y@(Ann yA yB) =+    withDict (recursively (Proxy @(ZipMatch t))) $+    withDict (recurse (Proxy @(RTraversable t))) $+    case zipMatch xB yB of+    Nothing -> Different (x :*: y)+    Just match ->+        case htraverse (const (^? _CommonSubTree)) sub of+        Nothing -> MkCommonBody (xA :*: yA) sub & CommonBody+        Just r -> Ann (xA :*: yA) r & CommonSubTree+        where+            sub =+                hmap+                ( Proxy @(Recursively ZipMatch) #*# Proxy @RTraversable #>+                    \(xC :*: yC) -> diff xC yC+                ) match++foldDiffs ::+    forall r h a b.+    (Monoid r, Recursively HFoldable h) =>+    (forall n. HRecWitness h n -> Ann a # n -> Ann b # n -> r) ->+    Diff a b # h ->+    r+foldDiffs _ CommonSubTree{} = mempty+foldDiffs f (Different (x :*: y)) = f HRecSelf x y+foldDiffs f (CommonBody (MkCommonBody _ x)) =+    withDict (recursively (Proxy @(HFoldable h))) $+    hfoldMap+    ( Proxy @(Recursively HFoldable) #*#+        \w -> foldDiffs (f . HRecSub w)+    ) x++data DiffP h+    = CommonSubTreeP (HPlain (GetHyperType h))+    | CommonBodyP (h :# DiffP)+    | DifferentP (HPlain (GetHyperType h)) (HPlain (GetHyperType h))+    deriving Generic+makePrisms ''DiffP++diffP ::+    forall h.+    (Recursively ZipMatch h, Recursively HasHPlain h, RTraversable h) =>+    HPlain h -> HPlain h -> DiffP # h+diffP x y =+    withDict (recursively (Proxy @(HasHPlain h))) $+    diffPH (x ^. hPlain) (y ^. hPlain)++diffPH ::+    forall h.+    (Recursively ZipMatch h, Recursively HasHPlain h, RTraversable h) =>+    Pure # h -> Pure # h -> DiffP # h+diffPH x y =+    withDict (recursively (Proxy @(ZipMatch h))) $+    withDict (recursively (Proxy @(HasHPlain h))) $+    withDict (recurse (Proxy @(RTraversable h))) $+    case zipMatch (x ^. _Pure) (y ^. _Pure) of+    Nothing -> DifferentP (hPlain # x) (hPlain # y)+    Just match ->+        case htraverse_ (const ((() <$) . (^? _CommonSubTreeP))) sub of+        Nothing -> CommonBodyP sub+        Just () -> _CommonSubTreeP . hPlain # x+        where+            sub =+                hmap+                ( Proxy @(Recursively ZipMatch) #*#+                    Proxy @(Recursively HasHPlain) #*#+                    Proxy @RTraversable #>+                    \(xC :*: yC) -> diffPH xC yC+                ) match++makeCommonInstances [''Diff, ''CommonBody, ''DiffP]++foldDiffsP ::+    forall r h.+    (Monoid r, Recursively HFoldable h, Recursively HasHPlain h) =>+    (forall n. HasHPlain n => HRecWitness h n -> HPlain n -> HPlain n -> r) ->+    DiffP # h ->+    r+foldDiffsP f =+    withDict (recursively (Proxy @(HasHPlain h))) $+    \case+    CommonSubTreeP{} -> mempty+    DifferentP x y -> f HRecSelf x y+    CommonBodyP x ->+        withDict (recursively (Proxy @(HFoldable h))) $+        hfoldMap+        ( Proxy @(Recursively HFoldable) #*# Proxy @(Recursively HasHPlain) #*#+            \w -> foldDiffsP (f . HRecSub w)+        ) x
+ src/Hyper/Infer.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleContexts #-}++module Hyper.Infer+    ( infer++    , InferResultsConstraint+    , inferUVarsApplyBindings++    , module Hyper.Class.Infer+    , module Hyper.Class.Infer.Env+    , module Hyper.Class.Infer.InferOf+    , module Hyper.Infer.ScopeLevel+    , module Hyper.Infer.Result++    , -- | Exported only for SPECIALIZE pragmas+      inferH+    ) where++import qualified Control.Lens as Lens+import           Hyper+import           Hyper.Class.Infer+import           Hyper.Class.Infer.Env+import           Hyper.Class.Infer.InferOf+import           Hyper.Class.Nodes (HNodesHaveConstraint(..))+import           Hyper.Infer.Result+import           Hyper.Infer.ScopeLevel+import           Hyper.Unify (Unify, UVarOf, applyBindings)++import           Hyper.Internal.Prelude++-- | Perform Hindley-Milner type inference of a term+{-# INLINE infer #-}+infer ::+    forall m t a.+    Infer m t =>+    Ann a # t ->+    m (Ann (a :*: InferResult (UVarOf m)) # t)+infer (Ann a x) =+    withDict (inferContext (Proxy @m) (Proxy @t)) $+    inferBody (hmap (Proxy @(Infer m) #> inferH) x)+    <&> (\(xI, t) -> Ann (a :*: InferResult t) xI)++{-# INLINE inferH #-}+inferH ::+    Infer m t =>+    Ann a # t ->+    InferChild m (Ann (a :*: InferResult (UVarOf m))) # t+inferH c = infer c <&> (\i -> InferredChild i (i ^. hAnn . Lens._2 . _InferResult)) & InferChild++type InferResultsConstraint c = Recursively (InferOfConstraint (HNodesHaveConstraint c))++inferUVarsApplyBindings ::+    forall m t a.+    ( Applicative m, RTraversable t, RTraversableInferOf t+    , InferResultsConstraint (Unify m) t+    ) =>+    Ann (a :*: InferResult (UVarOf m)) # t ->+    m (Ann (a :*: InferResult (Pure :*: UVarOf m)) # t)+inferUVarsApplyBindings =+    htraverseFlipped $+    Proxy @RTraversableInferOf #*#+    Proxy @(InferResultsConstraint (Unify m)) #>+    Lens._2 f+    where+        f ::+            forall n.+            ( HTraversable (InferOf n)+            , InferResultsConstraint (Unify m) n+            ) =>+            InferResult (UVarOf m) # n ->+            m (InferResult (Pure :*: UVarOf m) # n)+        f = withDict (recursively (Proxy @(InferOfConstraint (HNodesHaveConstraint (Unify m)) n))) $+            withDict (inferOfConstraint (Proxy @(HNodesHaveConstraint (Unify m))) (Proxy @n)) $+            withDict (hNodesHaveConstraint (Proxy @(Unify m)) (Proxy @(InferOf n))) $+            htraverseFlipped $+            Proxy @(Unify m) #>+            \x -> applyBindings x <&> (:*: x)
+ src/Hyper/Infer/Blame.hs view
@@ -0,0 +1,189 @@+-- | Hindley-Milner type inference with ergonomic blame assignment.+--+-- 'blame' is a type-error blame assignment algorithm for languages with Hindley-Milner type inference,+-- but __/without generalization of intermediate terms/__.+-- This means that it is not suitable for languages with let-generalization.+-- 'Hyper.Type.AST.Let.Let' is an example of a term that is not suitable for this algorithm.+--+-- With the contemporary knowledge that+-- ["Let Should Not Be Generalised"](https://www.microsoft.com/en-us/research/publication/let-should-not-be-generalised/),+-- as argued by luminaries such as Simon Peyton Jones,+-- optimistically this limitation shouldn't apply to new programming languages.+-- This blame assignment algorithm can also be used in a limited sense for existing languages,+-- which do have let-generalization, to provide better type errors+-- in specific definitions which don't happen to use generalizing terms.+--+-- The algorithm is pretty simple:+--+-- * Invoke all the 'inferBody' calls as 'Hyper.Infer.infer' normally would,+--   but with one important difference:+--   where 'inferBody' would normally get the actual inference results of its child nodes,+--   placeholders are generated in their place+-- * Globally sort all of the tree nodes according to a given node prioritization+--   (this prioritization would be custom for each language)+-- * According to the order of prioritization,+--   attempt to unify each infer-result with its placeholder using 'inferOfUnify'.+--   If a unification fails, roll back its state changes.+--   The nodes whose unification failed are the ones assigned with type errors.+--+-- [Lamdu](https://github.com/lamdu/lamdu) uses this algorithm for its "insist type" feature,+-- which moves around the blame for type mismatches.+--+-- Note: If a similar algorithm already existed somewhere,+-- [I](https://github.com/yairchu/) would very much like to know!++{-# LANGUAGE FlexibleContexts, TemplateHaskell, FlexibleInstances, UndecidableInstances #-}++module Hyper.Infer.Blame+    ( blame+    , Blame(..)+    , BlameResult(..), _Good, _Mismatch+    , InferOf'+    ) where++import qualified Control.Lens as Lens+import           Control.Monad.Except (MonadError(..))+import           Data.List (sortOn)+import           Hyper+import           Hyper.Class.Infer+import           Hyper.Class.Traversable (ContainedH(..))+import           Hyper.Class.Unify (UnifyGen, UVarOf)+import           Hyper.Infer.Result+import           Hyper.Recurse+import           Hyper.Unify.New (newUnbound)+import           Hyper.Unify.Occurs (occursCheck)++import           Hyper.Internal.Prelude++-- | Class implementing some primitives needed by the 'blame' algorithm+--+-- The 'blamableRecursive' method represents that 'Blame' applies to all recursive child nodes.+-- It replaces context for 'Blame' to avoid @UndecidableSuperClasses@.+class+    (Infer m t, RTraversable t, HTraversable (InferOf t), HPointed (InferOf t)) =>+    Blame m t where++    -- | Unify the types/values in infer results+    inferOfUnify ::+        Proxy t ->+        InferOf t # UVarOf m ->+        InferOf t # UVarOf m ->+        m ()++    -- | Check whether two infer results are the same+    inferOfMatches ::+        Proxy t ->+        InferOf t # UVarOf m ->+        InferOf t # UVarOf m ->+        m Bool++    -- TODO: Putting documentation here causes duplication in the haddock documentation+    blamableRecursive ::+        Proxy m -> Proxy t -> Dict (HNodesConstraint t (Blame m))+    {-# INLINE blamableRecursive #-}+    default blamableRecursive ::+        HNodesConstraint t (Blame m) =>+        Proxy m -> Proxy t -> Dict (HNodesConstraint t (Blame m))+    blamableRecursive _ _ = Dict++instance Recursive (Blame m) where+    recurse = blamableRecursive (Proxy @m) . proxyArgument++-- | A type synonym to help 'BlameResult' be more succinct+type InferOf' e v = InferOf (GetHyperType e) # v++prepareH ::+    forall m exp a.+    Blame m exp =>+    Ann a # exp ->+    m (Ann (a :*: InferResult (UVarOf m) :*: InferResult (UVarOf m)) # exp)+prepareH t =+    withDict (inferContext (Proxy @m) (Proxy @exp)) $+    hpure (Proxy @(UnifyGen m) #> MkContainedH newUnbound)+    & hsequence+    >>= (`prepare` t)++prepare ::+    forall m exp a.+    Blame m exp =>+    InferOf exp # UVarOf m ->+    Ann a # exp ->+    m (Ann (a :*: InferResult (UVarOf m) :*: InferResult (UVarOf m)) # exp)+prepare resFromPosition (Ann a x) =+    withDict (recurse (Proxy @(Blame m exp))) $+    hmap+    ( Proxy @(Blame m) #>+        InferChild . fmap (\t -> InferredChild t (t ^. hAnn . Lens._2 . Lens._1 . _InferResult)) . prepareH+    ) x+    & inferBody+    <&>+    \(xI, r) ->+    Ann (a :*: InferResult resFromPosition :*: InferResult r) xI++tryUnify ::+    forall err m top exp.+    (MonadError err m, Blame m exp) =>+    HWitness top exp ->+    InferOf exp # UVarOf m ->+    InferOf exp # UVarOf m ->+    m ()+tryUnify _ i0 i1 =+    withDict (inferContext (Proxy @m) (Proxy @exp)) $+    do+        inferOfUnify (Proxy @exp) i0 i1+        htraverse_ (Proxy @(UnifyGen m) #> occursCheck) i0+    & (`catchError` const (pure ()))++data BlameResult v e+    = Good (InferOf' e v)+    | Mismatch (InferOf' e v, InferOf' e v)+    deriving Generic+makePrisms ''BlameResult+makeCommonInstances [''BlameResult]++finalize ::+    forall a m exp.+    Blame m exp =>+    Ann (a :*: InferResult (UVarOf m) :*: InferResult (UVarOf m)) # exp ->+    m (Ann (a :*: BlameResult (UVarOf m)) # exp)+finalize (Ann (a :*: InferResult i0 :*: InferResult i1) x) =+    withDict (recurse (Proxy @(Blame m exp))) $+    do+        match <- inferOfMatches (Proxy @exp) i0 i1+        let result+                | match = Good i0+                | otherwise = Mismatch (i0, i1)+        htraverse (Proxy @(Blame m) #> finalize) x+            <&> Ann (a :*: result)++-- | Perform Hindley-Milner type inference with prioritised blame for type error,+-- given a prioritisation for the different nodes.+--+-- The purpose of the prioritisation is to place the errors in nodes where+-- the resulting errors will be easier to understand.+--+-- The expected `MonadError` behavior is that catching errors rolls back their state changes+-- (i.e @StateT s (Either e)@ is suitable but @EitherT e (State s)@ is not)+--+-- Gets the top-level type for the term for support of recursive definitions,+-- where the top-level type of the term may be in the scope of the inference monad.+blame ::+    forall priority err m exp a.+    ( Ord priority+    , MonadError err m+    , Blame m exp+    ) =>+    (forall n. a # n -> priority) ->+    InferOf exp # UVarOf m ->+    Ann a # exp ->+    m (Ann (a :*: BlameResult (UVarOf m)) # exp)+blame order topLevelType e =+    do+        p <- prepare topLevelType e+        hfoldMap+            ( Proxy @(Blame m) #*#+                \w (a :*: InferResult i0 :*: InferResult i1) ->+                [(order a, tryUnify w i0 i1)]+            ) (_HFlip # p)+            & sortOn fst & traverse_ snd+        finalize p
+ src/Hyper/Infer/Result.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell, UndecidableInstances, FlexibleInstances #-}++module Hyper.Infer.Result+    ( InferResult(..), _InferResult+    , inferResult+    ) where++import Hyper+import Hyper.Class.Infer+import Hyper.Internal.Prelude++-- | A 'HyperType' for an inferred term - the output of 'Hyper.Infer.infer'+newtype InferResult v e =+    InferResult (InferOf (GetHyperType e) # v)+    deriving stock Generic+makePrisms ''InferResult+makeCommonInstances [''InferResult]++-- An iso for the common case where the infer result of a term is a single value.+inferResult ::+    InferOf e ~ ANode t =>+    Iso (InferResult v0 # e)+        (InferResult v1 # e)+        (v0 # t)+        (v1 # t)+inferResult = _InferResult . _ANode++instance HNodes (InferOf e) => HNodes (HFlip InferResult e) where+    type HNodesConstraint (HFlip InferResult e) c = HNodesConstraint (InferOf e) c+    type HWitnessType (HFlip InferResult e) = HWitnessType (InferOf e)+    hLiftConstraint (HWitness w) = hLiftConstraint (HWitness @(InferOf e) w)++instance HFunctor (InferOf e) => HFunctor (HFlip InferResult e) where+    hmap f = _HFlip . _InferResult %~ hmap (f . HWitness . (^. _HWitness))++instance HFoldable (InferOf e) => HFoldable (HFlip InferResult e) where+    hfoldMap f = hfoldMap (f . HWitness . (^. _HWitness)) . (^. _HFlip . _InferResult)++instance HTraversable (InferOf e) => HTraversable (HFlip InferResult e) where+    hsequence = (_HFlip . _InferResult) hsequence
+ src/Hyper/Infer/ScopeLevel.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TemplateHaskell #-}++module Hyper.Infer.ScopeLevel+    ( ScopeLevel(..), _ScopeLevel+    , MonadScopeLevel(..)+    ) where++import           Algebra.PartialOrd (PartialOrd(..))+import           Hyper.Unify.Constraints (TypeConstraints(..))+import qualified Text.PrettyPrint as Pretty+import           Text.PrettyPrint.HughesPJClass (Pretty(..))++import           Hyper.Internal.Prelude++-- | A representation of scope nesting level,+-- for use in let-generalization and skolem escape detection.+--+-- See ["Efficient generalization with levels"](http://okmij.org/ftp/ML/generalization.html#levels)+-- for a detailed explanation.+--+-- Commonly used as the 'Hyper.Unify.Constraints.TypeConstraintsOf' of terms.+--+-- /Note/: The 'Ord' instance is only for use as a 'Data.Map.Map' key, not a+-- logical ordering, for which 'PartialOrd' is used.+newtype ScopeLevel = ScopeLevel Int+    deriving stock (Eq, Ord, Show, Generic)+makePrisms ''ScopeLevel++instance PartialOrd ScopeLevel where+    {-# INLINE leq #-}+    ScopeLevel x `leq` ScopeLevel y = x >= y++instance Semigroup ScopeLevel where+    {-# INLINE (<>) #-}+    ScopeLevel x <> ScopeLevel y = ScopeLevel (min x y)++instance Monoid ScopeLevel where+    {-# INLINE mempty #-}+    mempty = ScopeLevel maxBound++instance TypeConstraints ScopeLevel where+    {-# INLINE generalizeConstraints #-}+    generalizeConstraints _ = mempty+    toScopeConstraints = id++instance Pretty ScopeLevel where+    pPrint (ScopeLevel x)+        | x == maxBound = Pretty.text "*"+        | otherwise = Pretty.text "scope#" <> pPrint x++instance NFData ScopeLevel+instance Binary ScopeLevel++-- | A class of 'Monad's which maintain a scope level,+-- where the level can be locally increased for computations.+class Monad m => MonadScopeLevel m where+    localLevel :: m a -> m a
+ src/Hyper/Internal/Prelude.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TemplateHaskellQuotes #-}++module Hyper.Internal.Prelude+    ( makeCommonInstances++    , module X+    ) where++import Control.DeepSeq as X (NFData)+import Control.Lens as X (Traversal, Iso, makeLenses, makePrisms)+import Control.Lens.Operators as X+import Control.Monad as X (guard)+import Data.Binary as X (Binary)+import Data.Constraint as X (Dict(..), Constraint, withDict)+import Data.Foldable as X (traverse_, sequenceA_)+import Data.Functor.Const as X (Const(..))+import Data.Proxy as X (Proxy(..))+import Data.Map as X (Map)+import Data.Maybe as X (fromMaybe)+import Data.Set as X (Set)+import Generics.Constraints (makeDerivings, makeInstances)+import GHC.Generics as X (Generic, (:*:)(..))+import Language.Haskell.TH (Name, DecsQ)++import Prelude.Compat as X++-- Derive a specific list of classes that types in hypertypes implement.+makeCommonInstances :: [Name] -> DecsQ+makeCommonInstances names =+    (<>)+    <$> makeDerivings [''Eq, ''Ord, ''Show] names+    <*> makeInstances [''Binary, ''NFData] names
+ src/Hyper/Recurse.hs view
@@ -0,0 +1,155 @@+-- | Combinators for processing/constructing trees recursively++{-# LANGUAGE FlexibleContexts #-}++module Hyper.Recurse+    ( module Hyper.Class.Recursive+    , fold, unfold+    , wrap, wrapM, unwrap, unwrapM+    , foldMapRecursive+    , HRecWitness(..)+    , (#>>), (#**#), (##>>)+    ) where++import Hyper.Class.Foldable+import Hyper.Class.Functor (HFunctor(..))+import Hyper.Class.Nodes (HWitness, (#>), (#*#))+import Hyper.Class.Recursive+import Hyper.Class.Traversable+import Hyper.Type+import Hyper.Type.Pure (Pure(..), _Pure)++import Hyper.Internal.Prelude++-- | @HRecWitness h n@ is a witness that @n@ is a recursive node of @h@+data HRecWitness h n where+    HRecSelf :: HRecWitness h h+    HRecSub :: HWitness h c -> HRecWitness c n -> HRecWitness h n++-- | Monadically convert a 'Pure' to a different 'HyperType' from the bottom up+{-# INLINE wrapM #-}+wrapM ::+    forall m h w.+    (Monad m, RTraversable h) =>+    (forall n. HRecWitness h n -> n # w -> m (w # n)) ->+    Pure # h ->+    m (w # h)+wrapM f x =+    withDict (recurse (Proxy @(RTraversable h))) $+    x ^. _Pure+    & htraverse (Proxy @RTraversable #*# \w -> wrapM (f . HRecSub w))+    >>= f HRecSelf++-- | Monadically unwrap a tree from the top down, replacing its 'HyperType' with 'Pure'+{-# INLINE unwrapM #-}+unwrapM ::+    forall m h w.+    (Monad m, RTraversable h) =>+    (forall n. HRecWitness h n -> w # n -> m (n # w)) ->+    w # h ->+    m (Pure # h)+unwrapM f x =+    withDict (recurse (Proxy @(RTraversable h))) $+    f HRecSelf x+    >>= htraverse (Proxy @RTraversable #*# \w -> unwrapM (f . HRecSub w))+    <&> (_Pure #)++-- | Wrap a 'Pure' to a different 'HyperType' from the bottom up+{-# INLINE wrap #-}+wrap ::+    forall h w.+    Recursively HFunctor h =>+    (forall n. HRecWitness h n -> n # w -> w # n) ->+    Pure # h ->+    w # h+wrap f x =+    withDict (recursively (Proxy @(HFunctor h))) $+    x ^. _Pure+    & hmap (Proxy @(Recursively HFunctor) #*# \w -> wrap (f . HRecSub w))+    & f HRecSelf++-- | Unwrap a tree from the top down, replacing its 'HyperType' with 'Pure'+{-# INLINE unwrap #-}+unwrap ::+    forall h w.+    Recursively HFunctor h =>+    (forall n. HRecWitness h n -> w # n -> n # w) ->+    w # h ->+    Pure # h+unwrap f x =+    withDict (recursively (Proxy @(HFunctor h))) $+    _Pure #+    hmap (Proxy @(Recursively HFunctor) #*# \w -> unwrap (f . HRecSub w))+    (f HRecSelf x)++-- | Recursively fold up a tree to produce a result (aka catamorphism)+{-# INLINE fold #-}+fold ::+    Recursively HFunctor h =>+    (forall n. HRecWitness h n -> n # Const a -> a) ->+    Pure # h ->+    a+fold f = getConst . wrap (fmap Const . f)++-- | Build/load a tree from a seed value (aka anamorphism)+{-# INLINE unfold #-}+unfold ::+    Recursively HFunctor h =>+    (forall n. HRecWitness h n -> a -> n # Const a) ->+    a ->+    Pure # h+unfold f = unwrap (fmap (. getConst) f) . Const++-- | Fold over all of the recursive child nodes of a tree in pre-order+{-# INLINE foldMapRecursive #-}+foldMapRecursive ::+    forall h p a.+    (Recursively HFoldable h, Recursively HFoldable p, Monoid a) =>+    (forall n q. HRecWitness h n -> n # q -> a) ->+    h # p ->+    a+foldMapRecursive f x =+    withDict (recursively (Proxy @(HFoldable h))) $+    withDict (recursively (Proxy @(HFoldable p))) $+    f HRecSelf x <>+    hfoldMap+    ( Proxy @(Recursively HFoldable) #*#+        \w -> hfoldMap (Proxy @(Recursively HFoldable) #> foldMapRecursive (f . HRecSub w))+    ) x++infixr 0 #>>+infixr 0 ##>>+infixr 0 #**#++-- | @Proxy @c #> r@ replaces a recursive witness parameter of @r@ with a constraint on the witnessed node+{-# INLINE (#>>) #-}+(#>>) ::+    forall c h n r.+    (Recursive c, c h, RNodes h) =>+    Proxy c -> (c n => r) -> HRecWitness h n -> r+(#>>) _ r HRecSelf = r+(#>>) p r (HRecSub w0 w1) =+    withDict (recurse (Proxy @(RNodes h))) $+    withDict (recurse (Proxy @(c h))) $+    (Proxy @RNodes #*# p #> (p #>> r) w1) w0++-- | @Proxy @c #> r@ replaces a recursive witness parameter of @r@ with a @Recursively c@ constraint on the witnessed node+{-# INLINE (##>>) #-}+(##>>) ::+    forall c h n r.+    Recursively c h =>+    Proxy c -> (c n => r) -> HRecWitness h n -> r+(##>>) p r =+    withDict (recursively (Proxy @(c h))) $+    \case+    HRecSelf -> r+    HRecSub w0 w1 -> (Proxy @(Recursively c) #> (p ##>> r) w1) w0++-- | A variant of '#>>' which does not consume the witness parameter.+--+-- @Proxy @c0 #**# Proxy @c1 #>> r@ brings into context both the @c0 n@ and @c1 n@ constraints.+{-# INLINE (#**#) #-}+(#**#) ::+    (Recursive c, c h, RNodes h) =>+    Proxy c -> (HRecWitness h n -> (c n => r)) -> HRecWitness h n -> r+(#**#) p r w = (p #>> r) w w
+ src/Hyper/TH/Apply.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Generate 'HApply' and related instances via @TemplateHaskell@++module Hyper.TH.Apply+    ( makeHApply+    , makeHApplyAndBases+    , makeHApplicativeBases+    ) where++import           Control.Applicative (liftA2)+import qualified Control.Lens as Lens+import           Hyper.Class.Apply (HApply(..))+import           Hyper.TH.Functor (makeHFunctor)+import           Hyper.TH.Internal.Utils+import           Hyper.TH.Nodes (makeHNodes)+import           Hyper.TH.Pointed (makeHPointed)+import           Language.Haskell.TH++import           Hyper.Internal.Prelude++-- | Generate instances of 'HApply',+-- 'Hyper.Class.Functor.HFunctor', 'Hyper.Class.Pointed.HPointed' and 'Hyper.Class.Nodes.HNodes',+-- which together form 'HApplicative'.+makeHApplicativeBases :: Name -> DecsQ+makeHApplicativeBases x =+    sequenceA+    [ makeHPointed x+    , makeHApplyAndBases x+    ] <&> concat++-- | Generate an instance of 'HApply'+-- along with its bases 'Hyper.Class.Functor.HFunctor' and 'Hyper.Class.Nodes.HNodes'+makeHApplyAndBases :: Name -> DecsQ+makeHApplyAndBases x =+    sequenceA+    [ makeHNodes x+    , makeHFunctor x+    , makeHApply x+    ] <&> concat++-- | Generate an instance of 'HApply'+makeHApply :: Name -> DecsQ+makeHApply typeName = makeTypeInfo typeName >>= makeHApplyForType++makeHApplyForType :: TypeInfo -> DecsQ+makeHApplyForType info =+    do+        (name, _, fields) <-+            case tiConstructors info of+            [x] -> pure x+            _ -> fail "makeHApply only supports types with a single constructor"+        let xVars = makeConstructorVars "x" fields+        let yVars = makeConstructorVars "y" fields+        instanceD (makeContext info >>= simplifyContext) [t|HApply $(pure (tiInstance info))|]+            [ InlineP 'hzip Inline FunLike AllPhases & PragmaD & pure+            , funD 'hzip+                [ clause+                    [ consPat name xVars+                    , consPat name yVars+                    ] (normalB (foldl appE (conE name) (zipWith f xVars yVars))) []+                ]+            ]+            <&> (:[])+    where+        bodyFor (Right x) = bodyForPat x+        bodyFor Left{} = [|(<>)|]+        bodyForPat Node{} = [|(:*:)|]+        bodyForPat GenEmbed{} = [|hzip|]+        bodyForPat FlatEmbed{} = [|hzip|]+        bodyForPat (InContainer _ pat) = [|liftA2 $(bodyForPat pat)|]+        f (p, x) (_, y) = [|$(bodyFor p) $(varE x) $(varE y)|]++makeContext :: TypeInfo -> Q [Pred]+makeContext info =+    tiConstructors info >>= (^. Lens._3) & traverse ctxFor <&> mconcat+    where+        ctxFor (Right x) = ctxForPat x+        ctxFor (Left x) = [t|Semigroup $(pure x)|] <&> (:[])+        ctxForPat (InContainer t pat) = (:) <$> [t|Applicative $(pure t)|] <*> ctxForPat pat+        ctxForPat (GenEmbed t) = [t|HApply $(pure t)|] <&> (:[])+        ctxForPat (FlatEmbed t) = makeContext t+        ctxForPat _ = pure []
+ src/Hyper/TH/Context.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TemplateHaskell #-}++module Hyper.TH.Context+    ( makeHContext+    ) where++import qualified Control.Lens as Lens+import           Hyper.Class.Context (HContext(..))+import           Hyper.Class.Functor (HFunctor(..))+import           Hyper.Combinator.Func (HFunc(..), _HFunc)+import           Hyper.TH.Internal.Utils+import           Language.Haskell.TH+import           Language.Haskell.TH.Datatype (ConstructorVariant(..))++import           Hyper.Internal.Prelude++makeHContext :: Name -> DecsQ+makeHContext typeName = makeTypeInfo typeName >>= makeHContextForType++makeHContextForType :: TypeInfo -> DecsQ+makeHContextForType info =+    instanceD (simplifyContext (makeContext info)) [t|HContext $(pure (tiInstance info))|]+    [ InlineP 'hcontext Inline FunLike AllPhases & PragmaD & pure+    , funD 'hcontext (tiConstructors info <&> makeHContextCtr)+    ]+    <&> (:[])++makeContext :: TypeInfo -> [Pred]+makeContext info =+    tiConstructors info ^.. traverse . Lens._3 . traverse . Lens._Right >>= ctxForPat+    where+        ctxForPat (GenEmbed t) = embed t+        ctxForPat (FlatEmbed x) = embed (tiInstance x)+        ctxForPat _ = []+        embed t = [ConT ''HContext `AppT` t, ConT ''HFunctor `AppT` t]++makeHContextCtr ::+    (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> Q Clause+makeHContextCtr (cName, _, []) =+    clause [conP cName []] (normalB (conE cName)) []+makeHContextCtr (cName, RecordConstructor fieldNames, cFields) =+    clause [varWhole `asP` conP cName (cVars <&> varP)]+    (normalB (foldl appE (conE cName) (zipWith bodyFor cFields (zip fieldNames cVars)))) []+    where+        cVars =+            [(0 :: Int) ..] <&> show <&> ("_x" <>) <&> mkName+            & take (length cFields)+        bodyFor Left{} (_, v) = varE v+        bodyFor (Right Node{}) (f, v) =+            [|HFunc+                $(lamE [varP varField]+                    [|Lens.Const $(recUpdE (varE varWhole) [pure (f, VarE varField)])|])+                :*: $(varE v)|]+        bodyFor _ _ = fail "makeHContext only works for simple record fields"+        varWhole = mkName "_whole"+        varField = mkName "_field"+makeHContextCtr (cName, _, [cField]) =+    clause [conP cName [varP cVar]] (normalB (n `appE` bodyFor cField)) []+    where+        n = conE cName+        v = varE cVar+        bodyFor Left{} = v+        bodyFor (Right Node{}) = [|HFunc (Lens.Const . $n) :*: $v|]+        bodyFor (Right GenEmbed{}) = embed+        bodyFor (Right FlatEmbed{}) = embed+        bodyFor _ = fail "makeHContext only works for simple fields"+        embed =+            [|hmap+                (const (Lens._1 . _HFunc . Lens.mapped . Lens._Wrapped Lens.%~ $n))+                (hcontext $v)+            |]+        cVar = mkName "_c"+makeHContextCtr _ = fail "makeHContext: unsupported constructor"
+ src/Hyper/TH/Foldable.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Generate 'HFoldable' instances via @TemplateHaskell@++module Hyper.TH.Foldable+    ( makeHFoldable+    ) where++import qualified Control.Lens as Lens+import           Hyper.Class.Foldable (HFoldable(..))+import           Hyper.TH.Internal.Utils+import           Language.Haskell.TH+import           Language.Haskell.TH.Datatype (ConstructorVariant)++import           Hyper.Internal.Prelude++-- | Generate a 'HFoldable' instance+makeHFoldable :: Name -> DecsQ+makeHFoldable typeName = makeTypeInfo typeName >>= makeHFoldableForType++makeHFoldableForType :: TypeInfo -> DecsQ+makeHFoldableForType info =+    instanceD (makeContext info >>= simplifyContext) [t|HFoldable $(pure (tiInstance info))|]+    [ InlineP 'hfoldMap Inline FunLike AllPhases & PragmaD & pure+    , funD 'hfoldMap (tiConstructors info <&> makeCtr)+    ]+    <&> (:[])+    where+        (_, wit) = makeNodeOf info+        makeCtr ctr =+            clause [varP varF, pat] body []+            where+                (pat, body) = makeHFoldMapCtr 0 wit ctr++makeContext :: TypeInfo -> Q [Pred]+makeContext info =+    tiConstructors info ^.. traverse . Lens._3 . traverse . Lens._Right+    & traverse ctxForPat <&> mconcat+    where+        ctxForPat (InContainer t pat) = (:) <$> [t|Foldable $(pure t)|] <*> ctxForPat pat+        ctxForPat (GenEmbed t) = [t|HFoldable $(pure t)|] <&> (:[])+        ctxForPat (FlatEmbed t) = makeContext t+        ctxForPat _ = pure []++varF :: Name+varF = mkName "_f"++makeHFoldMapCtr :: Int -> NodeWitnesses -> (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> (Q Pat, Q Body)+makeHFoldMapCtr i wit (cName, _, cFields) =+    (conP cName (cVars <&> varP), body)+    where+        cVars =+            [i ..] <&> show <&> ("_x" <>) <&> mkName+            & take (length cFields)+        bodyParts =+            zipWith (\x y -> x <&> (`appE` y))+            (cFields <&> bodyFor)+            (cVars <&> varE)+            & concat+        body =+            case bodyParts of+            [] -> [|mempty|]+            _ -> foldl1 append bodyParts+            & normalB+        append x y = [|$x <> $y|]+        f = varE varF+        bodyFor (Right x) = bodyForPat x+        bodyFor Left{} = []+        bodyForPat (Node t) = [[|$f $(nodeWit wit t)|]]+        bodyForPat (GenEmbed t) = [[|hfoldMap ($f . $(embedWit wit t))|]]+        bodyForPat (InContainer _ pat) = bodyForPat pat <&> appE [|foldMap|]+        bodyForPat (FlatEmbed x) =+            [ lamCaseE+                (tiConstructors x+                    <&> makeHFoldMapCtr (i + length cVars) wit+                    <&> \(p, b) -> match p b []+                )+            ]
+ src/Hyper/TH/Functor.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Generate 'HFunctor' instances via @TemplateHaskell@++module Hyper.TH.Functor+    ( makeHFunctor+    ) where++import qualified Control.Lens as Lens+import           Hyper.Class.Functor (HFunctor(..))+import           Hyper.TH.Internal.Utils+import           Language.Haskell.TH+import           Language.Haskell.TH.Datatype (ConstructorVariant)++import           Hyper.Internal.Prelude++-- | Generate a 'HFunctor' instance+makeHFunctor :: Name -> DecsQ+makeHFunctor typeName = makeTypeInfo typeName >>= makeHFunctorForType++makeHFunctorForType :: TypeInfo -> DecsQ+makeHFunctorForType info =+    instanceD (makeContext info >>= simplifyContext) [t|HFunctor $(pure (tiInstance info))|]+    [ InlineP 'hmap Inline FunLike AllPhases & PragmaD & pure+    , funD 'hmap (tiConstructors info <&> makeCtr)+    ]+    <&> (:[])+    where+        (_, wit) = makeNodeOf info+        makeCtr ctr =+            clause [varP varF, pat] body []+            where+                (pat, body) = makeHMapCtr 0 wit ctr++varF :: Name+varF = mkName "_f"++makeContext :: TypeInfo -> Q [Pred]+makeContext info =+    tiConstructors info ^.. traverse . Lens._3 . traverse . Lens._Right+    & traverse ctxForPat <&> mconcat+    where+        ctxForPat (InContainer t pat) = (:) <$> [t|Functor $(pure t)|] <*> ctxForPat pat+        ctxForPat (GenEmbed t) = [t|HFunctor $(pure t)|] <&> (:[])+        ctxForPat (FlatEmbed t) = makeContext t+        ctxForPat _ = pure []++makeHMapCtr :: Int -> NodeWitnesses -> (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> (Q Pat, Q Body)+makeHMapCtr i wit (cName, _, cFields) =+    (conP cName (cVars <&> varP), body)+    where+        cVars =+            [i ..] <&> show <&> ('x':) <&> mkName+            & take (length cFields)+        body =+            zipWith bodyFor cFields cVars+            & foldl appE (conE cName)+            & normalB+        bodyFor (Right x) v = bodyForPat x `appE` varE v+        bodyFor Left{} v = varE v+        f = varE varF+        bodyForPat (Node t) = [|$f $(nodeWit wit t)|]+        bodyForPat (GenEmbed t) = [|hmap ($f . $(embedWit wit t))|]+        bodyForPat (InContainer _ pat) = [|fmap $(bodyForPat pat)|]+        bodyForPat (FlatEmbed x) =+            lamCaseE+            (tiConstructors x+                <&> makeHMapCtr (i + length cVars) wit+                <&> \(p, b) -> match p b []+            )
+ src/Hyper/TH/HasPlain.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Generate 'HasHPlain' instances via @TemplateHaskell@++module Hyper.TH.HasPlain+    ( makeHasHPlain+    ) where++import qualified Control.Lens as Lens+import qualified Data.Map as Map+import           Hyper.Class.HasPlain+import           Hyper.TH.Internal.Utils+import           Hyper.Type (GetHyperType)+import           Hyper.Type.Pure (Pure(..), _Pure)+import           Language.Haskell.TH+import qualified Language.Haskell.TH.Datatype as D++import           Hyper.Internal.Prelude++-- | Generate a 'HasHPlain' instance+makeHasHPlain :: [Name] -> DecsQ+makeHasHPlain x = traverse makeOne x <&> concat++makeOne :: Name -> Q [Dec]+makeOne typeName = makeTypeInfo typeName >>= makeHasHPlainForType++makeHasHPlainForType :: TypeInfo -> Q [Dec]+makeHasHPlainForType info =+    do+        ctrs <- traverse (makeCtr (tiName info) (tiHyperParam info)) (tiConstructors info)+        let typs = ctrs >>= (^. Lens._4) & filter (not . anHPlainOfCons)+        let plains =+                typs+                >>=+                \case+                ConT hplain `AppT` x | hplain == ''HPlain -> [x]+                _ -> []+        plainsCtx <- plains <&> AppT (ConT ''HasHPlain) & simplifyContext+        showCtx <- typs <&> AppT (ConT ''Show) & simplifyContext+        let makeDeriv cls =+                standaloneDerivD+                (typs <&> AppT (ConT cls) & simplifyContext)+                [t|$(conT cls) (HPlain $(pure (tiInstance info)))|]+        (:) <$> instanceD+                (pure (showCtx <> plainsCtx))+                [t|HasHPlain $(pure (tiInstance  info))|]+                [ dataInstD (pure []) ''HPlain [pure (tiInstance info)] Nothing (ctrs <&> pure . (^. Lens._1)) []+                , funD 'hPlain+                    [ clause []+                        (normalB [|Lens.iso $(varE fromPlain) $(varE toPlain) . Lens.from _Pure|])+                        [ funD toPlain (ctrs <&> (^. Lens._2))+                        , funD fromPlain (ctrs <&> (^. Lens._3))+                        ]+                    ]+                ]+            <*> traverse makeDeriv [''Eq, ''Ord, ''Show]+    where+        anHPlainOfCons (ConT hplain `AppT` x)+            | hplain == ''HPlain =+                case unapply x of+                (ConT{}, _) -> True+                _ -> False+        anHPlainOfCons _ = False+        toPlain = mkName "toPlain"+        fromPlain = mkName "fromPlain"++data FieldInfo = FieldInfo+    { fieldPlainType :: Type+    , fieldToPlain :: Q Exp -> Q Exp+    , fieldFromPlain :: Q Exp -> Q Exp+    }++data FlatInfo = FlatInfo+    { flatIsEmbed :: Bool+    , flatCtr :: Name+    , flatFields :: [Field]+    }++data Field+    = NodeField FieldInfo+    | FlatFields FlatInfo++makeCtr ::+    Name ->+    Name ->+    (Name, D.ConstructorVariant, [Either Type CtrTypePattern]) ->+    Q (Con, ClauseQ, ClauseQ, [Type])+makeCtr top param (cName, _, cFields) =+    traverse (forField True) cFields+    <&>+    \xs ->+    let plainTypes = xs >>= plainFieldTypes+        cVars = [0::Int ..] <&> show <&> ('x':) <&> mkName & take (length plainTypes)+    in+    ( plainTypes+        <&> (Bang NoSourceUnpackedness NoSourceStrictness, )+        & NormalC pcon+    , zipWith (>>=) (cVars <&> varE) (xs >>= toPlainFields)+        & foldl appE (conE pcon)+        & normalB+        <&> (\x -> Clause [ConP cName (toPlainPat cVars xs ^. Lens._1)] x [])+    , fromPlainFields cVars xs ^. Lens._1+        & foldl appE (conE cName)+        & normalB+        <&> \x -> Clause [ConP pcon (cVars <&> VarP)] x []+    , xs >>= fieldContext+    )+    where+        plainFieldTypes (NodeField x) = [fieldPlainType x]+        plainFieldTypes (FlatFields x) = flatFields x >>= plainFieldTypes+        toPlainFields (NodeField x) = [fieldToPlain x . pure]+        toPlainFields (FlatFields x) = flatFields x >>= toPlainFields+        toPlainPat cs [] = ([], cs)+        toPlainPat (c:cs) (NodeField{} : xs) = toPlainPat cs xs & Lens._1 %~ (VarP c :)+        toPlainPat cs0 (FlatFields x : xs) =+            toPlainPat cs1 xs & Lens._1 %~ (res :)+            where+                res | flatIsEmbed x = embed+                    | otherwise = ConP 'Pure [embed]+                embed = ConP (flatCtr x) r+                (r, cs1) = toPlainPat cs0 (flatFields x)+        toPlainPat [] _ = error "out of variables"+        fromPlainFields cs [] = ([], cs)+        fromPlainFields (c:cs) (NodeField x : xs) =+            fromPlainFields cs xs & Lens._1 %~ (fieldFromPlain x (varE c) :)+        fromPlainFields cs0 (FlatFields x : xs) =+            fromPlainFields cs1 xs & Lens._1 %~ (res :)+            where+                res | flatIsEmbed x = embed+                    | otherwise = [|Pure $embed|]+                embed = foldl appE (conE (flatCtr x)) r+                (r, cs1) = fromPlainFields cs0 (flatFields x)+        fromPlainFields [] _ = error "out of variables"+        pcon =+            show cName & reverse & takeWhile (/= '.') & reverse+            & (<> "P") & mkName+        forField _ (Left t) =+            FieldInfo+            <$> normalizeType t+            ?? id ?? id <&> NodeField+        forField isTop (Right x) = forPat isTop x+        forPat isTop (Node x) = forGen isTop x+        forPat isTop (GenEmbed x) = forGen isTop x+        forPat _ (InContainer t p) =+            FieldInfo+            <$> [t|$(pure t) $(patType p)|]+            ?? (\x -> [|(hPlain #) <$> $x|])+            ?? (\x -> [|(^. hPlain) <$> $x|])+            <&> NodeField+            where+                patType (Node x) = [t|HPlain $(pure x)|]+                patType (GenEmbed x) = [t|HPlain $(pure x)|]+                patType (FlatEmbed x) = [t|HPlain $(pure (tiInstance x))|]+                patType (InContainer t' p') = pure t' `appT` patType p'+        forPat isTop (FlatEmbed x) =+            case tiConstructors x of+            [(n, _, xs)] -> traverse (forField False) xs <&> FlatInfo isTop n <&> FlatFields+            _ -> forGen isTop (tiInstance x)+        forGen isTop t =+            case unapply t of+            (ConT c, args) ->+                reify c+                >>=+                \case+                FamilyI{} -> gen -- Not expanding type families currently+                _ ->+                    do+                        inner <- D.reifyDatatype c+                        let subst =+                                args <> [VarT param]+                                & zip (D.datatypeVars inner <&> D.tvName)+                                & Map.fromList+                        case D.datatypeCons inner of+                            [x] ->+                                D.constructorFields x+                                <&> D.applySubstitution subst+                                & traverse (matchType top param)+                                >>= traverse (forField False)+                                <&> FlatInfo isTop (D.constructorName x)+                                <&> FlatFields+                            _ -> gen+            _ -> gen+            where+                gen =+                    FieldInfo+                    <$> [t|HPlain $(pure t)|]+                    ?? (\x -> [|hPlain # $x|])+                    ?? (\f -> [|$f ^. hPlain|])+                    <&> NodeField+        normalizeType (ConT g `AppT` VarT v)+            | g == ''GetHyperType && v == param = [t|Pure|]+        normalizeType (x `AppT` y) = normalizeType x `appT` normalizeType y+        normalizeType x = pure x+        fieldContext (NodeField x) = [fieldPlainType x]+        fieldContext (FlatFields x) = flatFields x >>= fieldContext
+ src/Hyper/TH/Internal/Utils.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE TemplateHaskell, DerivingVia #-}++-- Helpers for TemplateHaskell instance generators++module Hyper.TH.Internal.Utils+    ( -- Internals for use in TH for sub-classes+      TypeInfo(..), TypeContents(..), CtrTypePattern(..), NodeWitnesses(..)+    , makeTypeInfo, makeNodeOf+    , parts, toTuple, matchType, niceName, mkNiceTypeName+    , applicativeStyle, unapply, getVar, makeConstructorVars+    , consPat, simplifyContext, childrenTypes+    ) where++import qualified Control.Lens as Lens+import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.State (State, evalState, execStateT, gets, modify)+import qualified Data.Char as Char+import           Data.List (nub, intercalate)+import qualified Data.Map as Map+import           Generic.Data (Generically(..))+import           Hyper.Class.Nodes (HWitness(..))+import           Hyper.Type (AHyperType(..), GetHyperType, type (:#))+import           Language.Haskell.TH+import qualified Language.Haskell.TH.Datatype as D++import           Hyper.Internal.Prelude++data TypeInfo = TypeInfo+    { tiName :: Name+    , tiInstance :: Type+    , tiParams :: [TyVarBndr]+    , tiHyperParam :: Name+    , tiConstructors :: [(Name, D.ConstructorVariant, [Either Type CtrTypePattern])]+    } deriving Show++data TypeContents = TypeContents+    { tcChildren :: Set Type+    , tcEmbeds :: Set Type+    , tcOthers :: Set Type+    } deriving (Show, Generic)+    deriving (Semigroup, Monoid) via Generically TypeContents++data CtrTypePattern+    = Node Type+    | FlatEmbed TypeInfo+    | GenEmbed Type+    | InContainer Type CtrTypePattern+    deriving Show++makeTypeInfo :: Name -> Q TypeInfo+makeTypeInfo name =+    do+        info <- D.reifyDatatype name+        (dst, var) <- parts info+        let makeCons c =+                traverse (matchType name var) (D.constructorFields c)+                <&> (D.constructorName c, D.constructorVariant c, )+        cons <- traverse makeCons (D.datatypeCons info)+        pure TypeInfo+            { tiName = name+            , tiInstance = dst+            , tiParams = D.datatypeVars info & init+            , tiHyperParam = var+            , tiConstructors = cons+            }++parts :: D.DatatypeInfo -> Q (Type, Name)+parts info =+    case D.datatypeVars info of+    [] -> fail "expected type constructor which requires arguments"+    xs ->+        case last xs of+        KindedTV var (ConT aHyper) | aHyper == ''AHyperType -> pure (res, var)+        PlainTV var -> pure (res, var)+        _ -> fail "expected last argument to be a AHyperType variable"+        where+            res =+                foldl AppT (ConT (D.datatypeName info)) (init xs <&> VarT . D.tvName)++childrenTypes :: TypeInfo -> TypeContents+childrenTypes info = evalState (childrenTypesH info) mempty++childrenTypesH ::+    TypeInfo -> State (Set Type) TypeContents+childrenTypesH info =+    do+        did <- gets (^. Lens.contains (tiInstance info))+        if did+            then pure mempty+            else+                modify (Lens.contains (tiInstance info) .~ True) *>+                traverse addPat (tiConstructors info ^.. traverse . Lens._3 . traverse . Lens._Right)+                    <&> mconcat+    where+        addPat (FlatEmbed inner) = childrenTypesH inner+        addPat (Node x) = pure mempty { tcChildren = mempty & Lens.contains x .~ True }+        addPat (GenEmbed x) = pure mempty { tcEmbeds = mempty & Lens.contains x .~ True }+        addPat (InContainer _ x) = addPat x++unapply :: Type -> (Type, [Type])+unapply =+    go []+    where+        go as (SigT x _) = go as x+        go as (AppT f a) = go (a:as) f+        go as x = (x, as)++matchType :: Name -> Name -> Type -> Q (Either Type CtrTypePattern)+matchType _ var (ConT get `AppT` VarT h `AppT` (PromotedT aHyper `AppT` x))+    | get == ''GetHyperType && aHyper == 'AHyperType && h == var =+        Node x & Right & pure+matchType _ var (InfixT (VarT h) hash x)+    | hash == ''(:#) && h == var =+        Node x & Right & pure+matchType _ var (ConT hash `AppT` VarT h `AppT` x)+    | hash == ''(:#) && h == var =+        Node x & Right & pure+matchType top var (x `AppT` VarT h)+    | h == var && x /= ConT ''GetHyperType =+        case unapply x of+        (ConT c, args) | c /= top ->+            do+                inner <- D.reifyDatatype c+                let innerVars = D.datatypeVars inner <&> D.tvName+                let subst =+                        args <> [VarT var]+                        & zip innerVars+                        & Map.fromList+                let makeCons i =+                        D.constructorFields i+                        <&> D.applySubstitution subst+                        & traverse (matchType top var)+                        <&> (D.constructorName i, D.constructorVariant i, )+                cons <- traverse makeCons (D.datatypeCons inner)+                if var `notElem` (D.freeVariablesWellScoped (cons ^.. traverse . Lens._3 . traverse . Lens._Left) <&> D.tvName)+                    then+                        FlatEmbed TypeInfo+                        { tiName = c+                        , tiInstance = x+                        , tiParams = D.datatypeVars inner & init+                        , tiHyperParam = var+                        , tiConstructors = cons+                        } & pure+                    else+                        GenEmbed x & pure+        _ -> GenEmbed x & pure+        <&> Right+matchType top var x@(AppT f a) =+    -- TODO: check if applied over a functor-kinded type.+    matchType top var a+    <&>+    \case+    Left{} -> Left x+    Right pat -> InContainer f pat & Right+matchType _ _ t = Left t & pure++getVar :: Type -> Maybe Name+getVar (VarT x) = Just x+getVar (SigT x _) = getVar x+getVar _ = Nothing++toTuple :: Foldable t => t Type -> Type+toTuple xs = foldl AppT (TupleT (length xs)) xs++applicativeStyle :: Q Exp -> [Q Exp] -> Q Exp+applicativeStyle f =+    foldl ap [|pure $f|]+    where+        ap x y = [|$x <*> $y|]++makeConstructorVars :: String -> [a] -> [(a, Name)]+makeConstructorVars prefix fields =+    [0::Int ..] <&> show <&> (('_':prefix) <>) <&> mkName+    & zip fields++consPat :: Name -> [(a, Name)] -> Q Pat+consPat c vars = conP c (vars <&> snd <&> varP)++simplifyContext :: [Pred] -> CxtQ+simplifyContext preds =+    execStateT (goPreds preds) (mempty :: Set (Name, [Type]), mempty :: Set Pred)+    <&> (^.. Lens._2 . Lens.folded)+    where+        goPreds ps = ps <&> unapply & traverse_ go+        go (c, [VarT v]) =+            -- Work-around reifyInstances returning instances for type variables+            -- by not checking.+            yep c [VarT v]+        go (ConT c, xs) =+            Lens.use (Lens._1 . Lens.contains key)+            >>=+            \case+            True -> pure () -- already checked+            False ->+                do+                    Lens._1 . Lens.contains key .= True+                    reifyInstances c xs & lift+                        >>=+                        \case+                        [InstanceD _ context other _] ->+                            D.unifyTypes [other, foldl AppT (ConT c) xs] & lift+                            <&> (`D.applySubstitution` context)+                            >>= goPreds+                        _ -> yep (ConT c) xs+            where+                key = (c, xs)+        go (c, xs) = yep c xs+        yep c xs = Lens._2 . Lens.contains (foldl AppT c xs) .= True++data NodeWitnesses = NodeWitnesses+    { nodeWit :: Type -> Q Exp+    , embedWit :: Type -> Q Exp+    , nodeWitCtrs :: [Name]+    , embedWitCtrs :: [Name]+    }++niceName :: Name -> String+niceName = reverse . takeWhile (/= '.') . reverse . show++makeNodeOf :: TypeInfo -> ([Type -> Q Con], NodeWitnesses)+makeNodeOf info =+    ( (nodes <&> Lens._1 %~ nodeGadtType) <> (embeds <&> Lens._1 %~ embedGadtType)+        <&> \(t, n) c -> t c <&> GadtC [n] []+    , NodeWitnesses+        { nodeWit = nodes & Map.fromList & getWit <&> \x -> [|HWitness $(conE x)|]+        , embedWit = embeds & Map.fromList & getWit <&> \x -> [|HWitness . $(conE x)|]+        , nodeWitCtrs = nodes <&> snd+        , embedWitCtrs = embeds <&> snd+        }+    )+    where+        niceTypeName = tiName info & niceName+        nodeBase = "W_" <> niceTypeName <> "_"+        embedBase = "E_" <> niceTypeName <> "_"+        pats = tiConstructors info >>= (^. Lens._3)+        nodes =+            pats ^.. traverse . Lens._Right >>= nodesForPat & nub+            <&> \t -> (t, mkName (nodeBase <> mkNiceTypeName t))+        nodesForPat (Node t) = [t]+        nodesForPat (InContainer _ pat) = nodesForPat pat+        nodesForPat (FlatEmbed x) = tiConstructors x ^.. traverse . Lens._3 . traverse . Lens._Right >>= nodesForPat+        nodesForPat _ = []+        nodeGadtType t n = n `AppT` t & pure+        embeds =+            pats ^.. traverse . Lens._Right >>= embedsForPat & nub+            <&> \t -> (t, mkName (embedBase <> mkNiceTypeName t))+        embedsForPat (GenEmbed t) = [t]+        embedsForPat (InContainer _ pat) = embedsForPat pat+        embedsForPat (FlatEmbed x) = tiConstructors x ^.. traverse . Lens._3 . traverse . Lens._Right >>= embedsForPat+        embedsForPat _ = []+        embedGadtType t n = [t|HWitness $(pure t) $nodeVar -> $(pure n) $nodeVar|]+        nodeVar = mkName "node" & varT+        getWit :: Map Type Name -> Type -> Name+        getWit m h =+            m ^? Lens.ix h+            & fromMaybe (error ("Cant find witness for " <> show h <> " in " <> show m))++mkNiceTypeName :: Type -> String+mkNiceTypeName =+    intercalate "_" . makeNiceType+    where+        makeNiceType (ConT x) =+            case niceName x of+            n@(c:_) | Char.isAlpha c -> [n]+            _ -> [] -- Skip operators+        makeNiceType (AppT x y) = makeNiceType x <> makeNiceType y+        makeNiceType (VarT x) = [takeWhile (/= '_') (show x)]+        makeNiceType (SigT x _) = makeNiceType x+        makeNiceType x = error ("TODO: Witness name generator is partial! Need to support " <> show x)
+ src/Hyper/TH/Morph.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE TemplateHaskell, CPP #-}++module Hyper.TH.Morph+    ( makeHMorph+    ) where++import qualified Control.Lens as Lens+import qualified Data.Map as Map+import           Hyper.Class.Morph (HMorph(..))+import           Hyper.TH.Internal.Utils+import           Language.Haskell.TH+import qualified Language.Haskell.TH.Datatype as D++import           Hyper.Internal.Prelude++makeHMorph :: Name -> DecsQ+makeHMorph typeName = makeTypeInfo typeName >>= makeHMorphForType++makeHMorphForType :: TypeInfo -> DecsQ+makeHMorphForType info =+    -- TODO: Contexts+    instanceD (pure []) [t|HMorph $(pure src) $(pure dst)|]+    [ D.tySynInstDCompat+        ''MorphConstraint+        (Just [pure (PlainTV constraintVar)])+        ([src, dst, VarT constraintVar] <&> pure)+        (simplifyContext morphConstraint <&> toTuple)+    , dataInstD+        (pure []) ''MorphWitness [pure src, pure dst, [t|_|], [t|_|]]+        Nothing (witnesses ^.. traverse . Lens._2) []+    , funD 'morphMap (tiConstructors info <&> mkMorphCon)+    , funD 'morphLiftConstraint liftConstraintClauses+    ]+    <&> (:[])+    where+        (s0, s1) = paramSubsts info+        src = D.applySubstitution s0 (tiInstance info)+        dst = D.applySubstitution s1 (tiInstance info)+        constraintVar = mkName "constraint"+        contents = childrenTypes info+        morphConstraint =+            (tcChildren contents ^.. Lens.folded <&> appSubsts (VarT constraintVar))+            <> (tcEmbeds contents ^.. Lens.folded <&>+                \x -> ConT ''MorphConstraint `appSubsts` x `AppT` VarT constraintVar)+        appSubsts x t = x `AppT` D.applySubstitution s0 t `AppT` D.applySubstitution s1 t+        nodeWits =+            tcChildren contents ^.. Lens.folded <&>+            \x ->+            let n = witPrefix <> mkNiceTypeName x & mkName in+            ( x+            , (n, gadtC [n] [] (pure (appSubsts morphWithNessOf x)))+            )+        embedWits =+            tcEmbeds contents ^.. Lens.folded <&>+            \x ->+            let n = witPrefix <> mkNiceTypeName x & mkName in+            ( x+            , ( n+                , gadtC [n] []+                    [t|$(pure (ConT ''MorphWitness `appSubsts` x `AppT` varA `AppT` varB)) ->+                        $(pure morphWithNessOf) $(pure varA) $(pure varB)|])+            )+        witnesses = nodeWits <> embedWits & Map.fromList+        varA = VarT (mkName "a")+        varB = VarT (mkName "b")+        witPrefix = "M_" <> niceName (tiName info) <> "_"+        morphWithNessOf = ConT ''MorphWitness `AppT` src `AppT` dst+        liftConstraintClauses+            | Map.null witnesses = [clause [] (normalB (lamCaseE [])) []]+            | otherwise =+                (nodeWits ^.. traverse . Lens._2 . Lens._1 <&> liftNodeConstraint) <>+                (embedWits ^.. traverse . Lens._2 . Lens._1 <&> liftEmbedConstraint)+        liftNodeConstraint n = clause [conP n [], wildP] (normalB [|id|]) []+        liftEmbedConstraint n =+            clause [conP n [varP varW], varP varProxy]+            (normalB [|morphLiftConstraint $(varE varW) $(varE varProxy)|]) []+        varW = mkName "w"+        varProxy = mkName "p"+        mkMorphCon con =+            clause [varP varF, p] b []+            where+                (p, b) = morphCon 0 witnesses con++varF :: Name+varF = mkName "_f"++morphCon :: Int -> Map Type (Name, a) -> (Name, b, [Either c CtrTypePattern]) -> (Q Pat, Q Body)+morphCon i witnesses (n, _, fields) =+    ( conP n (cVars <&> varP)+    , normalB (foldl appE (conE n) (zipWith bodyFor fields cVars))+    )+    where+        cVars =+            [i ..] <&> show <&> ('x':) <&> mkName+            & take (length fields)+        f = varE varF+        bodyFor Left{} v = varE v+        bodyFor (Right x) v = [|$(bodyForPat x) $(varE v)|]+        bodyForPat (Node x) = [|$f $(conE (witnesses ^?! Lens.ix x . Lens._1))|]+        bodyForPat (InContainer _ pat) = [|fmap $(bodyForPat pat)|]+        bodyForPat (FlatEmbed x) =+            lamCaseE+            (tiConstructors x+                <&> morphCon (i + length cVars) witnesses+                <&> \(p, b) -> match p b []+            )+        bodyForPat (GenEmbed t) = [|morphMap ($f . $(conE (witnesses ^?! Lens.ix t . Lens._1)))|]++type MorphSubsts = (Map Name Type, Map Name Type)++paramSubsts :: TypeInfo -> MorphSubsts+paramSubsts info =+    (tiParams info <&> D.tvName) ^. traverse . Lens.to mkInfo+    where+        pinned = pinnedParams info+        mkInfo name+            | pinned ^. Lens.contains name = mempty+            | otherwise = (side name "0", side name "1")+        side name suffix = mempty & Lens.at name ?~ VarT (mkName (nameBase name <> suffix))++pinnedParams :: TypeInfo -> Set Name+pinnedParams = (^. Lens.to tiConstructors . traverse . Lens._3 . traverse . Lens.to ctrPinnedParams)++ctrPinnedParams :: Either Type CtrTypePattern -> Set Name+ctrPinnedParams (Left t) = typeParams t+ctrPinnedParams (Right Node{}) = mempty+ctrPinnedParams (Right GenEmbed{}) = mempty+ctrPinnedParams (Right (FlatEmbed info)) = pinnedParams info+ctrPinnedParams (Right (InContainer c p)) = typeParams c <> ctrPinnedParams (Right p)++typeParams :: Type -> Set Name+typeParams (VarT x) = mempty & Lens.contains x .~ True+typeParams (AppT f x) = typeParams f <> typeParams x+typeParams (InfixT x _ y) = typeParams x <> typeParams y+-- TODO: Missing cases+typeParams _ = mempty
+ src/Hyper/TH/Nodes.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TemplateHaskell, EmptyCase #-}++-- | Generate 'HNodes' instances via @TemplateHaskell@++module Hyper.TH.Nodes+    ( makeHNodes+    ) where++import qualified Control.Lens as Lens+import           GHC.Generics (V1)+import           Hyper.Class.Nodes (HNodes(..), HWitness(..))+import           Hyper.TH.Internal.Utils+import           Language.Haskell.TH+import qualified Language.Haskell.TH.Datatype as D++import           Hyper.Internal.Prelude++-- | Generate a 'HNodes' instance+makeHNodes :: Name -> DecsQ+makeHNodes typeName = makeTypeInfo typeName >>= makeHNodesForType++makeHNodesForType :: TypeInfo -> DecsQ+makeHNodesForType info =+    [ instanceD (simplifyContext (makeContext info)) [t|HNodes $(pure (tiInstance info))|]+        [ D.tySynInstDCompat+            ''HNodesConstraint+            (Just [pure (PlainTV constraintVar)])+            [pure (tiInstance info), c]+            (nodesConstraint >>= simplifyContext <&> toTuple)+        , D.tySynInstDCompat ''HWitnessType Nothing [pure (tiInstance info)] witType+        , InlineP 'hLiftConstraint Inline FunLike AllPhases & PragmaD & pure+        , funD 'hLiftConstraint (makeHLiftConstraints wit)+        ]+    ] <> witDecs+    & sequenceA+    where+        (witType, witDecs)+            | null nodeOfCons = ([t|V1|], [])+            | otherwise =+                ( tiParams info <&> varT . D.tvName & foldl appT (conT witTypeName)+                , [dataD (pure []) witTypeName+                    (tiParams info <> [PlainTV (mkName "node")])+                    Nothing (nodeOfCons <&> (witType >>=)) []+                    ]+                )+            where+                witTypeName = mkName ("W_" <> niceName (tiName info))+        (nodeOfCons, wit) = makeNodeOf info+        constraintVar = mkName "constraint"+        c = varT constraintVar+        contents = childrenTypes info+        nodesConstraint =+            (tcChildren contents ^.. Lens.folded <&> (c `appT`) . pure)+            <> (tcEmbeds contents ^.. Lens.folded <&> \x -> [t|HNodesConstraint $(pure x) $c|])+            <> (tcOthers contents ^.. Lens.folded <&> pure)+            & sequenceA++makeContext :: TypeInfo -> [Pred]+makeContext info =+    tiConstructors info ^.. traverse . Lens._3 . traverse . Lens._Right >>= ctxForPat+    where+        ctxForPat (InContainer _ pat) = ctxForPat pat+        ctxForPat (GenEmbed t) = [ConT ''HNodes `AppT` t]+        ctxForPat _ = []++makeHLiftConstraints :: NodeWitnesses -> [Q Clause]+makeHLiftConstraints wit+    | null clauses = [clause [] (normalB [|\case|]) []]+    | otherwise = clauses+    where+        clauses = (nodeWitCtrs wit <&> liftNode) <> (embedWitCtrs wit <&> liftEmbed)+        liftNode x = clause [conP 'HWitness [conP x []]] (normalB [|const id|]) []+        liftEmbed x =+            clause [conP 'HWitness [conP x [varP witVar]]]+            (normalB [|hLiftConstraint $(varE witVar)|]) []+        witVar :: Name+        witVar = mkName "witness"
+ src/Hyper/TH/Pointed.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Generate 'HPointed' instances via @TemplateHaskell@++module Hyper.TH.Pointed+    ( makeHPointed+    ) where++import qualified Control.Lens as Lens+import           Hyper.Class.Pointed (HPointed(..))+import           Hyper.TH.Internal.Utils+import           Language.Haskell.TH+import           Language.Haskell.TH.Datatype (ConstructorVariant)++import           Hyper.Internal.Prelude++-- | Generate a 'HPointed' instance+makeHPointed :: Name -> DecsQ+makeHPointed typeName = makeTypeInfo typeName >>= makeHPointedForType++makeHPointedForType :: TypeInfo -> DecsQ+makeHPointedForType info =+    do+        cons <-+            case tiConstructors info of+            [x] -> pure x+            _ -> fail "makeHPointed only supports types with a single constructor"+        instanceD (makeContext info >>= simplifyContext) [t|HPointed $(pure (tiInstance info))|]+            [ InlineP 'hpure Inline FunLike AllPhases & PragmaD & pure+            , funD 'hpure [makeHPureCtr info cons]+            ]+    <&> (:[])++makeContext :: TypeInfo -> Q [Pred]+makeContext info =+    tiConstructors info >>= (^. Lens._3) & traverse ctxFor <&> mconcat+    where+        ctxFor (Right x) = ctxForPat x+        ctxFor (Left x) = [t|Monoid $(pure x)|] <&> (:[])+        ctxForPat (InContainer t pat) = (:) <$> [t|Applicative $(pure t)|] <*> ctxForPat pat+        ctxForPat (GenEmbed t) = [t|HPointed $(pure t)|] <&> (:[])+        ctxForPat (FlatEmbed t) = makeContext t+        ctxForPat _ = pure []++makeHPureCtr :: TypeInfo -> (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> Q Clause+makeHPureCtr typeInfo (cName, _, cFields) =+    clause [varP varF] (normalB (foldl appE (conE cName) (cFields <&> bodyFor))) []+    where+        bodyFor (Right x) = bodyForPat x+        bodyFor Left{} = [|mempty|]+        f = varE varF+        bodyForPat (Node t) = [|$f $(nodeWit wit t)|]+        bodyForPat (FlatEmbed inner) =+            case tiConstructors inner of+            [(iName, _, iFields)] -> iFields <&> bodyFor & foldl appE (conE iName)+            _ -> fail "makeHPointed only supports embedded types with a single constructor"+        bodyForPat (GenEmbed t) = [|hpure ($f . $(embedWit wit t))|]+        bodyForPat (InContainer _ pat) = [|pure $(bodyForPat pat)|]+        varF = mkName "_f"+        (_, wit) = makeNodeOf typeInfo
+ src/Hyper/TH/Traversable.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Generate 'HTraversable' and related instances via @TemplateHaskell@++module Hyper.TH.Traversable+    ( makeHTraversable+    , makeHTraversableAndFoldable+    , makeHTraversableAndBases+    , makeHTraversableApplyAndBases+    ) where++import qualified Control.Lens as Lens+import           Hyper.Class.Traversable (HTraversable(..), ContainedH(..))+import           Hyper.TH.Apply (makeHApplicativeBases)+import           Hyper.TH.Foldable (makeHFoldable)+import           Hyper.TH.Functor (makeHFunctor)+import           Hyper.TH.Internal.Utils+import           Hyper.TH.Nodes (makeHNodes)+import           Language.Haskell.TH+import           Language.Haskell.TH.Datatype (ConstructorVariant)++import           Hyper.Internal.Prelude++-- | Generate 'HTraversable' and 'Hyper.Class.Apply.HApply' instances along with all of their base classes:+-- 'Hyper.Class.Foldable.HFoldable', 'Hyper.Class.Functor.HFunctor',+-- 'Hyper.Class.Pointed.HPointed', and 'Hyper.Class.Nodes.HNodes'.+makeHTraversableApplyAndBases :: Name -> DecsQ+makeHTraversableApplyAndBases x =+    sequenceA+    [ makeHApplicativeBases x+    , makeHTraversableAndFoldable x+    ] <&> concat++-- | Generate a 'HTraversable' instance along with the instance of its base classes:+-- 'Hyper.Class.Foldable.HFoldable', 'Hyper.Class.Functor.HFunctor', and 'Hyper.Class.Nodes.HNodes'.+makeHTraversableAndBases :: Name -> DecsQ+makeHTraversableAndBases x =+    sequenceA+    [ makeHNodes x+    , makeHFunctor x+    , makeHTraversableAndFoldable x+    ] <&> concat++-- | Generate 'HTraversable' and 'Hyper.Class.Foldable.HFoldable' instances+makeHTraversableAndFoldable :: Name -> DecsQ+makeHTraversableAndFoldable x =+    sequenceA+    [ makeHFoldable x+    , makeHTraversable x+    ] <&> concat++-- | Generate a 'HTraversable' instance+makeHTraversable :: Name -> DecsQ+makeHTraversable typeName = makeTypeInfo typeName >>= makeHTraversableForType++makeHTraversableForType :: TypeInfo -> DecsQ+makeHTraversableForType info =+    instanceD (makeContext info >>= simplifyContext) [t|HTraversable $(pure (tiInstance info))|]+    [ InlineP 'hsequence Inline FunLike AllPhases & PragmaD & pure+    , funD 'hsequence (tiConstructors info <&> makeCons)+    ]+    <&> (:[])++makeContext :: TypeInfo -> Q [Pred]+makeContext info =+    tiConstructors info ^.. traverse . Lens._3 . traverse . Lens._Right+    & traverse ctxForPat <&> mconcat+    where+        ctxForPat (InContainer t pat) = (:) <$> [t|Traversable $(pure t)|] <*> ctxForPat pat+        ctxForPat (GenEmbed t) = [t|HTraversable $(pure t)|] <&> (:[])+        ctxForPat (FlatEmbed t) = makeContext t+        ctxForPat _ = pure []++makeCons ::+    (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> ClauseQ+makeCons (cName, _, cFields) =+    clause [consPat cName consVars] body []+    where+        body =+            consVars <&> f+            & applicativeStyle (conE cName)+            & normalB+        consVars = makeConstructorVars "x" cFields+        f (pat, name) = bodyFor pat `appE` varE name+        bodyFor (Right x) = bodyForPat x+        bodyFor Left{} = [|pure|]+        bodyForPat Node{} = [|runContainedH|]+        bodyForPat FlatEmbed{} = [|hsequence|]+        bodyForPat GenEmbed{} = [|hsequence|]+        bodyForPat (InContainer _ pat) = [|traverse $(bodyForPat pat)|]
+ src/Hyper/TH/ZipMatch.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Generate 'ZipMatch' instances via @TemplateHaskell@++module Hyper.TH.ZipMatch+    ( makeZipMatch+    ) where++import Control.Lens (both)+import Hyper.Class.ZipMatch (ZipMatch(..))+import Hyper.TH.Internal.Utils+import Language.Haskell.TH+import Language.Haskell.TH.Datatype (ConstructorVariant)++import Hyper.Internal.Prelude++-- | Generate a 'ZipMatch' instance+makeZipMatch :: Name -> DecsQ+makeZipMatch typeName =+    do+        info <- makeTypeInfo typeName+        -- (dst, var) <- parts info+        let ctrs = tiConstructors info <&> makeZipMatchCtr+        instanceD+            (ctrs >>= ccContext & sequenceA >>= simplifyContext)+            (appT (conT ''ZipMatch) (pure (tiInstance info)))+            [ InlineP 'zipMatch Inline FunLike AllPhases & PragmaD & pure+            , funD 'zipMatch ((ctrs <&> ccClause) <> [tailClause])+            ]+            <&> (:[])+    where+        tailClause = clause [wildP, wildP] (normalB [|Nothing|]) []++data CtrCase =+    CtrCase+    { ccClause :: Q Clause+    , ccContext :: [Q Pred]+    }++makeZipMatchCtr :: (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> CtrCase+makeZipMatchCtr (cName, _, cFields) =+    CtrCase+    { ccClause = clause [con fst, con snd] body []+    , ccContext = fieldParts >>= zmfContext+    }+    where+        con f = conP cName (cVars <&> f <&> varP)+        cVars =+            [0::Int ..] <&> show <&> (\n -> (mkName ('x':n), mkName ('y':n)))+            & take (length cFields)+        body+            | null checks = normalB bodyExp+            | otherwise = guardedB [(,) <$> normalG (foldl1 mkAnd checks) <*> bodyExp]+        checks = fieldParts >>= zmfConds+        mkAnd x y = [|$x && $y|]+        fieldParts = zipWith field (cVars <&> both %~ varE) cFields+        bodyExp = applicativeStyle (conE cName) (fieldParts <&> zmfResult)+        field (x, y) (Right Node{}) =+            ZipMatchField+            { zmfResult = [|Just ($x :*: $y)|]+            , zmfConds = []+            , zmfContext = []+            }+        field (x, y) (Right (GenEmbed t)) = embed t x y+        field (x, y) (Right (FlatEmbed t)) = embed (tiInstance t) x y+        field _ (Right InContainer{}) = error "TODO"+        field (x, y) (Left t) =+            ZipMatchField+            { zmfResult = [|Just $x|]+            , zmfConds =  [[|$x == $y|]]+            , zmfContext = [[t|Eq $(pure t)|]]+            }+        embed t x y =+            ZipMatchField+            { zmfResult = [|zipMatch $x $y|]+            , zmfConds = []+            , zmfContext = [[t|ZipMatch $(pure t)|]]+            }++data ZipMatchField = ZipMatchField+    { zmfResult :: Q Exp+    , zmfConds :: [Q Exp]+    , zmfContext :: [Q Pred]+    }
+ src/Hyper/Type.hs view
@@ -0,0 +1,50 @@+-- | A 'HyperType' is a type parameterized by a hypertype.+--+-- This infinite definition is expressible using the 'AHyperType' 'Data.Kind.Kind' for hypertypes.+--+-- For more information see the [README](https://github.com/lamdu/hypertypes/blob/master/README.md).++module Hyper.Type+    ( HyperType+    , AHyperType(..), GetHyperType+    , type (#), type (:#)+    , asHyper+    ) where++import Data.Kind (Type)++import Prelude.Compat++-- | A hypertype is a type parameterized by a hypertype+type HyperType = AHyperType -> Type++-- | A 'Data.Kind.Kind' for 'HyperType's+newtype AHyperType = AHyperType HyperType++-- | A type-level getter for the type constructor encoded in 'AHyperType'.+--+-- Notes:+--+-- * If @DataKinds@ supported lifting field getters this would had been replaced with the type's getter.+-- * 'GetHyperType' is injective, but due to no support for constrained type families,+--   [that's not expressible at the moment](https://ghc.haskell.org/trac/ghc/ticket/15691).+-- * Because 'GetHyperType' can't declared as bijective, uses of it may restrict inference.+--   In those cases wrapping terms with the 'asHyper' helper assists Haskell's type inference+--   as if Haskell knew that 'GetHyperType' was bijective.+type family GetHyperType h where+    GetHyperType ('AHyperType t) = t++-- | A type synonym to express nested-HKD structures+type h # p = (h ('AHyperType p) :: Type)++-- | A type synonym to express child nodes in nested-HKDs+type h :# p = GetHyperType h # p++-- | An 'id' variant which tells the type checker that its argument is a hypertype.+--+-- See the notes for 'GetHyperType' which expand on why this might be used.+--+-- Note that 'asHyper' may often be used during development to assist the inference of incomplete code,+-- but removed once the code is complete.+asHyper :: h # p -> h # p+asHyper = id
+ src/Hyper/Type/AST/App.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, TemplateHaskell #-}++module Hyper.Type.AST.App+    ( App(..), appFunc, appArg, W_App(..), MorphWitness(..)+    ) where++import Hyper+import Hyper.Class.Optic (HSubset(..), HSubset')+import Hyper.Infer+import Hyper.Type.AST.FuncType+import Hyper.Unify (UnifyGen, unify)+import Hyper.Unify.New (newTerm, newUnbound)+import Text.PrettyPrint ((<+>))+import Text.PrettyPrint.HughesPJClass (Pretty(..), maybeParens)++import Hyper.Internal.Prelude++-- | A term for function applications.+--+-- @App expr@s express function applications of @expr@s.+--+-- Apart from the data type, an 'Infer' instance is also provided.+data App expr h = App+    { _appFunc :: h :# expr+    , _appArg :: h :# expr+    } deriving Generic++makeLenses ''App+makeZipMatch ''App+makeHContext ''App+makeHMorph ''App+makeHTraversableApplyAndBases ''App+makeCommonInstances [''App]++instance RNodes e => RNodes (App e)+instance (c (App e), Recursively c e) => Recursively c (App e)+instance RTraversable e => RTraversable (App e)++instance Pretty (h :# expr) => Pretty (App expr h) where+    pPrintPrec lvl p (App f x) =+        pPrintPrec lvl 10 f <+>+        pPrintPrec lvl 11 x+        & maybeParens (p > 10)++type instance InferOf (App e) = ANode (TypeOf e)++instance+    ( Infer m expr+    , HasInferredType expr+    , HSubset' (TypeOf expr) (FuncType (TypeOf expr))+    , UnifyGen m (TypeOf expr)+    ) =>+    Infer m (App expr) where++    {-# INLINE inferBody #-}+    inferBody (App func arg) =+        do+            InferredChild argI argR <- inferChild arg+            InferredChild funcI funcR <- inferChild func+            funcRes <- newUnbound+            (App funcI argI, MkANode funcRes) <$+                (newTerm (hSubset # FuncType (argR ^# l) funcRes) >>= unify (funcR ^# l))+        where+            l = inferredType (Proxy @expr)
+ src/Hyper/Type/AST/FuncType.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE UndecidableInstances, TemplateHaskell #-}++module Hyper.Type.AST.FuncType+    ( FuncType(..), funcIn, funcOut, W_FuncType(..), MorphWitness(..)+    ) where++import           Generics.Constraints (makeDerivings, makeInstances)+import           Hyper+import           Text.PrettyPrint ((<+>))+import qualified Text.PrettyPrint as Pretty+import           Text.PrettyPrint.HughesPJClass (Pretty(..), maybeParens)+import           Text.Show.Combinators ((@|), showCon)++import           Hyper.Internal.Prelude++-- | A term for the types of functions. Analogues to @(->)@ in Haskell.+--+-- @FuncType typ@s express types of functions of @typ@.+data FuncType typ h = FuncType+    { _funcIn  :: h :# typ+    , _funcOut :: h :# typ+    } deriving Generic++makeLenses ''FuncType+makeZipMatch ''FuncType+makeHContext ''FuncType+makeHMorph ''FuncType+makeHTraversableApplyAndBases ''FuncType+makeDerivings [''Eq, ''Ord] [''FuncType]+makeInstances [''Binary, ''NFData] [''FuncType]++instance Pretty (h :# typ) => Pretty (FuncType typ h) where+    pPrintPrec lvl p (FuncType i o) =+        pPrintPrec lvl 11 i <+> Pretty.text "->" <+> pPrintPrec lvl 10 o+        & maybeParens (p > 10)++instance Show (h :# typ) => Show (FuncType typ h) where+    showsPrec p (FuncType i o) = (showCon "FuncType" @| i @| o) p
+ src/Hyper/Type/AST/Lam.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, UndecidableInstances #-}++module Hyper.Type.AST.Lam+    ( Lam(..), lamIn, lamOut, W_Lam(..), MorphWitness(..)+    ) where++import           Generics.Constraints (Constraints)+import           Hyper+import           Hyper.Class.Optic (HSubset(..), HSubset')+import           Hyper.Infer+import           Hyper.Type.AST.FuncType+import           Hyper.Unify (UnifyGen, UVarOf)+import           Hyper.Unify.New (newUnbound, newTerm)+import qualified Text.PrettyPrint as P+import           Text.PrettyPrint.HughesPJClass (Pretty(..), maybeParens)++import           Hyper.Internal.Prelude++-- | A term for lambda abstractions.+--+-- @Lam v expr@s express lambda abstractions with @v@s as variable names and @expr@s for bodies.+--+-- Apart from the data type, an 'Infer' instance is also provided.+data Lam v expr h = Lam+    { _lamIn :: v+    , _lamOut :: h :# expr+    } deriving Generic++makeLenses ''Lam+makeCommonInstances [''Lam]+makeHTraversableApplyAndBases ''Lam+makeZipMatch ''Lam+makeHContext ''Lam+makeHMorph ''Lam++instance RNodes t => RNodes (Lam v t)+instance (c (Lam v t), Recursively c t) => Recursively c (Lam v t)+instance RTraversable t => RTraversable (Lam v t)++instance+    Constraints (Lam v expr h) Pretty =>+    Pretty (Lam v expr h) where+    pPrintPrec lvl p (Lam i o) =+        (P.text "λ" <> pPrintPrec lvl 0 i)+        P.<+> P.text "→" P.<+> pPrintPrec lvl 0 o+        & maybeParens (p > 0)++type instance InferOf (Lam _ t) = ANode (TypeOf t)++instance+    ( Infer m t+    , UnifyGen m (TypeOf t)+    , HSubset' (TypeOf t) (FuncType (TypeOf t))+    , HasInferredType t+    , LocalScopeType v (UVarOf m # TypeOf t) m+    ) =>+    Infer m (Lam v t) where++    {-# INLINE inferBody #-}+    inferBody (Lam p r) =+        do+            varType <- newUnbound+            InferredChild rI rR <- inferChild r & localScopeType p varType+            hSubset # FuncType varType (rR ^# inferredType (Proxy @t))+                & newTerm+                <&> MkANode+                <&> (Lam p rI,)
+ src/Hyper/Type/AST/Let.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TemplateHaskell, UndecidableInstances, FlexibleInstances #-}++module Hyper.Type.AST.Let+    ( Let(..), letVar, letEquals, letIn, W_Let(..), MorphWitness(..)+    ) where++import           Generics.Constraints (Constraints)+import           Hyper+import           Hyper.Class.Unify (UnifyGen, UVarOf)+import           Hyper.Infer+import           Hyper.Unify.Generalize (GTerm, generalize)+import           Text.PrettyPrint (($+$), (<+>))+import qualified Text.PrettyPrint as Pretty+import           Text.PrettyPrint.HughesPJClass (Pretty(..), maybeParens)++import           Hyper.Internal.Prelude++-- | A term for let-expressions with let-generalization.+--+-- @Let v expr@s express let-expressions with @v@s as variable names and @expr@s for terms.+--+-- Apart from the data type, an 'Infer' instance is also provided.+data Let v expr h = Let+    { _letVar :: v+    , _letEquals :: h :# expr+    , _letIn :: h :# expr+    } deriving (Generic)++makeLenses ''Let+makeCommonInstances [''Let]+makeHTraversableApplyAndBases ''Let+makeZipMatch ''Let+makeHContext ''Let+makeHMorph ''Let++instance+    Constraints (Let v expr h) Pretty =>+    Pretty (Let v expr h) where+    pPrintPrec lvl p (Let v e i) =+        Pretty.text "let" <+> pPrintPrec lvl 0 v <+> Pretty.text "="+        <+> pPrintPrec lvl 0 e+        $+$ pPrintPrec lvl 0 i+        & maybeParens (p > 0)++type instance InferOf (Let _ e) = InferOf e++instance+    ( MonadScopeLevel m+    , LocalScopeType v (GTerm (UVarOf m) # TypeOf expr) m+    , UnifyGen m (TypeOf expr)+    , HasInferredType expr+    , HNodesConstraint (InferOf expr) (UnifyGen m)+    , HTraversable (InferOf expr)+    , Infer m expr+    ) =>+    Infer m (Let v expr) where++    inferBody (Let v e i) =+        do+            (eI, eG) <-+                do+                    InferredChild eI eR <- inferChild e+                    generalize (eR ^# inferredType (Proxy @expr))+                        <&> (eI ,)+                & localLevel+            inferChild i+                & localScopeType v eG+                <&> \(InferredChild iI iR) -> (Let v eI iI, iR)
+ src/Hyper/Type/AST/Map.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, UndecidableInstances #-}++module Hyper.Type.AST.Map+    ( TermMap(..), _TermMap, W_TermMap(..), MorphWitness(..)+    ) where++import qualified Control.Lens as Lens+import qualified Data.Map as Map+import           Hyper+import           Hyper.Class.ZipMatch (ZipMatch(..))++import           Hyper.Internal.Prelude++-- | A mapping of keys to terms.+--+-- Apart from the data type, a 'ZipMatch' instance is also provided.+newtype TermMap h expr f = TermMap (Map h (f :# expr))+    deriving stock Generic++makePrisms ''TermMap+makeCommonInstances [''TermMap]+makeHTraversableApplyAndBases ''TermMap+makeHMorph ''TermMap++instance Eq h => ZipMatch (TermMap h expr) where+    {-# INLINE zipMatch #-}+    zipMatch (TermMap x) (TermMap y)+        | Map.size x /= Map.size y = Nothing+        | otherwise =+            zipMatchList (x ^@.. Lens.itraversed) (y ^@.. Lens.itraversed)+            <&> traverse . Lens._2 %~ uncurry (:*:)+            <&> TermMap . Map.fromAscList++{-# INLINE zipMatchList #-}+zipMatchList :: Eq k => [(k, a)] -> [(k, b)] -> Maybe [(k, (a, b))]+zipMatchList [] [] = Just []+zipMatchList ((k0, v0) : xs) ((k1, v1) : ys)+    | k0 == k1 =+        zipMatchList xs ys <&> ((k0, (v0, v1)) :)+zipMatchList _ _ = Nothing
+ src/Hyper/Type/AST/Nominal.hs view
@@ -0,0 +1,361 @@+-- | Nominal (named) types declaration, instantiation, construction, and access.++{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts, TemplateHaskell, EmptyCase #-}++module Hyper.Type.AST.Nominal+    ( NominalDecl(..), nParams, nScheme, W_NominalDecl(..)+    , NominalInst(..), nId, nArgs+    , ToNom(..), tnId, tnVal, W_ToNom(..)+    , FromNom(..), _FromNom++    , HasNominalInst(..)+    , NomVarTypes+    , MonadNominals(..)+    , LoadedNominalDecl, loadNominalDecl+    ) where++import           Control.Applicative (Alternative(..))+import           Control.Lens (Prism')+import qualified Control.Lens as Lens+import           Control.Monad.Trans.Writer (execWriterT)+import           Generics.Constraints (Constraints)+import           Hyper+import           Hyper.Class.Context (HContext(..))+import           Hyper.Class.Optic+import           Hyper.Class.Traversable (ContainedH(..))+import           Hyper.Class.ZipMatch (ZipMatch(..))+import           Hyper.Infer+import           Hyper.Recurse+import           Hyper.Type.AST.FuncType (FuncType(..))+import           Hyper.Type.AST.Map (TermMap(..), _TermMap)+import           Hyper.Type.AST.Scheme+import           Hyper.Unify+import           Hyper.Unify.Generalize (GTerm(..), _GMono, instantiateWith, instantiateForAll)+import           Hyper.Unify.New (newTerm)+import           Hyper.Unify.QuantifiedVar (HasQuantifiedVar(..), OrdQVar)+import           Hyper.Unify.Term (UTerm(..))+import qualified Text.PrettyPrint as P+import           Text.PrettyPrint.HughesPJClass (Pretty(..), maybeParens)++import           Hyper.Internal.Prelude++type family NomVarTypes (t :: HyperType) :: HyperType++-- | A declaration of a nominal type.+data NominalDecl typ h = NominalDecl+    { _nParams :: NomVarTypes typ # QVars+    , _nScheme :: Scheme (NomVarTypes typ) typ h+    } deriving Generic++-- | An instantiation of a nominal type+data NominalInst nomId varTypes h = NominalInst+    { _nId :: nomId+    , _nArgs :: varTypes # QVarInstances (GetHyperType h)+    } deriving Generic++-- | Nominal data constructor.+--+-- Wrap content with a data constructor+-- (analogues to a data constructor of a Haskell `newtype`'s).+--+-- Introduces the nominal's foralled type variables into the value's scope.+data ToNom nomId term h = ToNom+    { _tnId :: nomId+    , _tnVal :: h :# term+    } deriving Generic++-- | Access the data in a nominally typed value.+--+-- Analogues to a getter of a Haskell `newtype`.+newtype FromNom nomId (term :: HyperType) (h :: AHyperType) = FromNom nomId+    deriving newtype (Eq, Ord, Binary, NFData)+    deriving stock (Show, Generic)++-- | A nominal declaration loaded into scope in an inference monad.+data LoadedNominalDecl typ v = LoadedNominalDecl+    { _lnParams :: NomVarTypes typ # QVarInstances (GetHyperType v)+    , _lnForalls :: NomVarTypes typ # QVarInstances (GetHyperType v)+    , _lnType :: GTerm (GetHyperType v) # typ+    } deriving Generic++makeLenses ''NominalDecl+makeLenses ''NominalInst+makeLenses ''ToNom+makePrisms ''FromNom+makeCommonInstances [''NominalDecl, ''NominalInst, ''ToNom, ''LoadedNominalDecl]+makeHTraversableAndBases ''NominalDecl+makeHTraversableApplyAndBases ''ToNom+makeHTraversableApplyAndBases ''FromNom+makeHMorph ''ToNom+makeZipMatch ''ToNom+makeZipMatch ''FromNom+makeHContext ''ToNom+makeHContext ''FromNom++instance HNodes v => HNodes (NominalInst n v) where+    type HNodesConstraint (NominalInst n v) c = HNodesConstraint v c+    type HWitnessType (NominalInst n v) = HWitnessType v+    {-# INLINE hLiftConstraint #-}+    hLiftConstraint (HWitness w) = hLiftConstraint @v (HWitness w)++instance HFunctor v => HFunctor (NominalInst n v) where+    {-# INLINE hmap #-}+    hmap f = nArgs %~ hmap (\(HWitness w) -> _QVarInstances . Lens.mapped %~ f (HWitness w))++instance HFoldable v => HFoldable (NominalInst n v) where+    {-# INLINE hfoldMap #-}+    hfoldMap f =+        hfoldMap (\(HWitness w) -> foldMap (f (HWitness w)) . (^. _QVarInstances)) . (^. nArgs)++instance HTraversable v => HTraversable (NominalInst n v) where+    {-# INLINE hsequence #-}+    hsequence (NominalInst n v) =+        htraverse (const (_QVarInstances (traverse runContainedH))) v+        <&> NominalInst n++instance+    ( Eq nomId+    , ZipMatch varTypes+    , HTraversable varTypes+    , HNodesConstraint varTypes ZipMatch+    , HNodesConstraint varTypes OrdQVar+    ) =>+    ZipMatch (NominalInst nomId varTypes) where++    {-# INLINE zipMatch #-}+    zipMatch (NominalInst xId x) (NominalInst yId y)+        | xId /= yId = Nothing+        | otherwise =+            zipMatch x y+            >>= htraverse+                ( Proxy @ZipMatch #*# Proxy @OrdQVar #>+                    \(QVarInstances c0 :*: QVarInstances c1) ->+                    zipMatch (TermMap c0) (TermMap c1)+                    <&> (^. _TermMap)+                    <&> QVarInstances+                )+            <&> NominalInst xId++instance+    ( HFunctor varTypes+    , HContext varTypes+    , HNodesConstraint varTypes OrdQVar+    ) => HContext (NominalInst nomId varTypes) where+    hcontext (NominalInst n args) =+        hcontext args+        & hmap+            ( Proxy @OrdQVar #>+                \(HFunc c :*: x) ->+                x & _QVarInstances . Lens.imapped %@~+                \k v ->+                HFunc+                ( \newV ->+                    x+                    & _QVarInstances . Lens.at k ?~ newV+                    & c & getConst & NominalInst n+                    & Const+                ) :*: v+            )+        & NominalInst n++instance Constraints (ToNom nomId term h) Pretty => Pretty (ToNom nomId term h) where+    pPrintPrec lvl p (ToNom nomId term) =+        (pPrint nomId <> P.text "#") P.<+> pPrintPrec lvl 11 term+        & maybeParens (p > 10)++class    (Pretty (QVar h), Pretty (outer :# h)) => PrettyConstraints outer h+instance (Pretty (QVar h), Pretty (outer :# h)) => PrettyConstraints outer h++instance+    ( Pretty nomId+    , HApply varTypes, HFoldable varTypes+    , HNodesConstraint varTypes (PrettyConstraints h)+    ) =>+    Pretty (NominalInst nomId varTypes h) where++    pPrint (NominalInst n vars) =+        pPrint n <>+        joinArgs+        (hfoldMap (Proxy @(PrettyConstraints h) #> mkArgs) vars)+        where+            joinArgs [] = mempty+            joinArgs xs = P.text "[" <> P.sep (P.punctuate (P.text ",") xs) <> P.text "]"+            mkArgs (QVarInstances m) =+                m ^@.. Lens.itraversed <&>+                \(h, v) ->+                (pPrint h <> P.text ":") P.<+> pPrint v++{-# ANN module "HLint: ignore Use camelCase" #-}+data W_LoadedNominalDecl t n where+    E_LoadedNominalDecl_Body :: HRecWitness t n -> W_LoadedNominalDecl t n+    E_LoadedNominalDecl_NomVarTypes :: HWitness (NomVarTypes t) n -> W_LoadedNominalDecl t n++instance (RNodes t, HNodes (NomVarTypes t)) => HNodes (LoadedNominalDecl t) where+    type HNodesConstraint (LoadedNominalDecl t) c =+        ( HNodesConstraint (NomVarTypes t) c+        , c t+        , Recursive c+        )+    type HWitnessType (LoadedNominalDecl t) = W_LoadedNominalDecl t+    {-# INLINE hLiftConstraint #-}+    hLiftConstraint (HWitness (E_LoadedNominalDecl_Body w)) = hLiftConstraint @(HFlip GTerm _) (HWitness w)+    hLiftConstraint (HWitness (E_LoadedNominalDecl_NomVarTypes w)) = hLiftConstraint w++instance+    (Recursively HFunctor typ, HFunctor (NomVarTypes typ)) =>+    HFunctor (LoadedNominalDecl typ) where+    {-# INLINE hmap #-}+    hmap f (LoadedNominalDecl mp mf t) =+        LoadedNominalDecl (onMap mp) (onMap mf)+        (t & hflipped %~ hmap (\(HWitness w) -> f (HWitness (E_LoadedNominalDecl_Body w))))+        where+            onMap = hmap (\w -> _QVarInstances . Lens.mapped %~ f (HWitness (E_LoadedNominalDecl_NomVarTypes w)))++instance+    (Recursively HFoldable typ, HFoldable (NomVarTypes typ)) =>+    HFoldable (LoadedNominalDecl typ) where+    {-# INLINE hfoldMap #-}+    hfoldMap f (LoadedNominalDecl mp mf t) =+        onMap mp <> onMap mf <>+        hfoldMap (\(HWitness w) -> f (HWitness (E_LoadedNominalDecl_Body w))) (_HFlip # t)+        where+            onMap =+                hfoldMap (\w -> foldMap (f (HWitness (E_LoadedNominalDecl_NomVarTypes w)))+                . (^. _QVarInstances))++instance+    (RTraversable typ, HTraversable (NomVarTypes typ)) =>+    HTraversable (LoadedNominalDecl typ) where+    {-# INLINE hsequence #-}+    hsequence (LoadedNominalDecl p f t) =+        LoadedNominalDecl+        <$> onMap p+        <*> onMap f+        <*> hflipped hsequence t+        where+            onMap = htraverse (const ((_QVarInstances . traverse) runContainedH))++{-# INLINE loadBody #-}+loadBody ::+    ( UnifyGen m typ+    , HNodeLens varTypes typ+    , Ord (QVar typ)+    ) =>+    varTypes # QVarInstances (UVarOf m) ->+    varTypes # QVarInstances (UVarOf m) ->+    typ # GTerm (UVarOf m) ->+    m (GTerm (UVarOf m) # typ)+loadBody params foralls x =+    case x ^? quantifiedVar >>= get of+    Just r -> GPoly r & pure+    Nothing ->+        case htraverse (const (^? _GMono)) x of+        Just xm -> newTerm xm <&> GMono+        Nothing -> GBody x & pure+    where+        get v =+            params ^? hNodeLens . _QVarInstances . Lens.ix v <|>+            foralls ^? hNodeLens . _QVarInstances . Lens.ix v++{-# INLINE loadNominalDecl #-}+loadNominalDecl ::+    forall m typ.+    ( Monad m+    , HTraversable (NomVarTypes typ)+    , HNodesConstraint (NomVarTypes typ) (Unify m)+    , HasScheme (NomVarTypes typ) m typ+    ) =>+    Pure # NominalDecl typ ->+    m (LoadedNominalDecl typ # UVarOf m)+loadNominalDecl (Pure (NominalDecl params (Scheme foralls typ))) =+    do+        paramsL <- htraverse (Proxy @(Unify m) #> makeQVarInstances) params+        forallsL <- htraverse (Proxy @(Unify m) #> makeQVarInstances) foralls+        wrapM+            (Proxy @(HasScheme (NomVarTypes typ) m) #>>+                loadBody paramsL forallsL+            ) typ+            <&> LoadedNominalDecl paramsL forallsL++class MonadNominals nomId typ m where+    getNominalDecl :: nomId -> m (LoadedNominalDecl typ # UVarOf m)++class HasNominalInst nomId typ where+    nominalInst :: Prism' (typ # h) (NominalInst nomId (NomVarTypes typ) # h)++{-# INLINE lookupParams #-}+lookupParams ::+    forall m varTypes.+    ( Applicative m+    , HTraversable varTypes+    , HNodesConstraint varTypes (UnifyGen m)+    ) =>+    varTypes # QVarInstances (UVarOf m) ->+    m (varTypes # QVarInstances (UVarOf m))+lookupParams =+    htraverse (Proxy @(UnifyGen m) #> (_QVarInstances . traverse) lookupParam)+    where+        lookupParam :: forall t. UnifyGen m t => UVarOf m # t -> m (UVarOf m # t)+        lookupParam v =+            lookupVar binding v+            >>=+            \case+            UInstantiated r -> pure r+            USkolem l ->+                -- This is a phantom-type, wasn't instantiated by `instantiate`.+                scopeConstraints (Proxy @t) <&> (<> l) >>= newVar binding . UUnbound+            _ -> error "unexpected state at nominal's parameter"++type instance InferOf (ToNom n e) = NominalInst n (NomVarTypes (TypeOf e))++instance+    ( MonadScopeLevel m+    , MonadNominals nomId (TypeOf expr) m+    , HTraversable (NomVarTypes (TypeOf expr))+    , HNodesConstraint (NomVarTypes (TypeOf expr)) (UnifyGen m)+    , UnifyGen m (TypeOf expr)+    , HasInferredType expr+    , Infer m expr+    ) =>+    Infer m (ToNom nomId expr) where++    {-# INLINE inferBody #-}+    inferBody (ToNom nomId val) =+        do+            (InferredChild valI valR, typ, paramsT) <-+                do+                    v <- inferChild val+                    LoadedNominalDecl params foralls gen <- getNominalDecl nomId+                    recover <-+                        htraverse_+                        ( Proxy @(UnifyGen m) #>+                            traverse_ (instantiateForAll USkolem) . (^. _QVarInstances)+                        ) foralls+                        & execWriterT+                    (typ, paramsT) <- instantiateWith (lookupParams params) UUnbound gen+                    (v, typ, paramsT) <$ sequence_ recover+                & localLevel+            (ToNom nomId valI, NominalInst nomId paramsT)+                <$ unify typ (valR ^# inferredType (Proxy @expr))++type instance InferOf (FromNom _ e) = FuncType (TypeOf e)++instance+    ( Infer m expr+    , HasNominalInst nomId (TypeOf expr)+    , MonadNominals nomId (TypeOf expr) m+    , HTraversable (NomVarTypes (TypeOf expr))+    , HNodesConstraint (NomVarTypes (TypeOf expr)) (UnifyGen m)+    , UnifyGen m (TypeOf expr)+    ) =>+    Infer m (FromNom nomId expr) where++    {-# INLINE inferBody #-}+    inferBody (FromNom nomId) =+        do+            LoadedNominalDecl params _ gen <- getNominalDecl nomId+            (typ, paramsT) <- instantiateWith (lookupParams params) UUnbound gen+            nominalInst # NominalInst nomId paramsT & newTerm+                <&> (`FuncType` typ)+        <&> (FromNom nomId, )
+ src/Hyper/Type/AST/Row.hs view
@@ -0,0 +1,163 @@+-- | Row types++{-# LANGUAGE FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell #-}++module Hyper.Type.AST.Row+    ( RowConstraints(..), RowKey+    , RowExtend(..), eKey, eVal, eRest, W_RowExtend(..)+    , FlatRowExtends(..), freExtends, freRest, W_FlatRowExtends(..)+    , MorphWitness(..)+    , flattenRow, flattenRowExtend, unflattenRow+    , verifyRowExtendConstraints, rowExtendStructureMismatch+    , rowElementInfer+    ) where++import           Control.Lens (Prism', Lens', contains)+import qualified Control.Lens as Lens+import           Control.Monad (foldM)+import qualified Data.Map as Map+import           Generics.Constraints (Constraints, makeDerivings, makeInstances)+import           Hyper+import           Hyper.Unify+import           Hyper.Unify.New (newTerm, newUnbound)+import           Hyper.Unify.Term (UTerm(..), _UTerm, UTermBody(..), uBody)+import           Text.Show.Combinators ((@|), showCon)++import           Hyper.Internal.Prelude++class+    (Ord (RowConstraintsKey constraints), TypeConstraints constraints) =>+    RowConstraints constraints where++    type RowConstraintsKey constraints+    forbidden :: Lens' constraints (Set (RowConstraintsKey constraints))++type RowKey typ = RowConstraintsKey (TypeConstraintsOf typ)++-- | Row-extend primitive for use in both value-level and type-level+data RowExtend key val rest h = RowExtend+    { _eKey :: key+    , _eVal :: h :# val+    , _eRest :: h :# rest+    } deriving Generic++data FlatRowExtends key val rest h = FlatRowExtends+    { _freExtends :: Map key (h :# val)+    , _freRest :: h :# rest+    } deriving Generic++makeLenses ''RowExtend+makeLenses ''FlatRowExtends+makeCommonInstances [''FlatRowExtends]+makeZipMatch ''RowExtend+makeHContext ''RowExtend+makeHMorph ''RowExtend+makeHTraversableApplyAndBases ''RowExtend+makeHTraversableApplyAndBases ''FlatRowExtends+makeDerivings [''Eq, ''Ord] [''RowExtend]+makeInstances [''Binary, ''NFData] [''RowExtend]++instance+    Constraints (RowExtend key val rest h) Show =>+    Show (RowExtend key val rest h) where+    showsPrec p (RowExtend h v r) = (showCon "RowExtend" @| h @| v @| r) p++{-# INLINE flattenRowExtend #-}+flattenRowExtend ::+    (Ord key, Monad m) =>+    (v # rest -> m (Maybe (RowExtend key val rest # v))) ->+    RowExtend key val rest # v ->+    m (FlatRowExtends key val rest # v)+flattenRowExtend nextExtend (RowExtend h v rest) =+    flattenRow nextExtend rest+    <&> freExtends %~ Map.unionWith (error "Colliding keys") (Map.singleton h v)++{-# INLINE flattenRow #-}+flattenRow ::+    (Ord key, Monad m) =>+    (v # rest -> m (Maybe (RowExtend key val rest # v))) ->+    v # rest ->+    m (FlatRowExtends key val rest # v)+flattenRow nextExtend x =+    nextExtend x+    >>= maybe (pure (FlatRowExtends mempty x)) (flattenRowExtend nextExtend)++{-# INLINE unflattenRow #-}+unflattenRow ::+    Monad m =>+    (RowExtend key val rest # v -> m (v # rest)) ->+    FlatRowExtends key val rest # v -> m (v # rest)+unflattenRow mkExtend (FlatRowExtends fields rest) =+    fields ^@.. Lens.itraversed & foldM f rest+    where+        f acc (key, val) = RowExtend key val acc & mkExtend++-- Helpers for Unify instances of type-level RowExtends:++{-# INLINE verifyRowExtendConstraints #-}+verifyRowExtendConstraints ::+    RowConstraints (TypeConstraintsOf rowTyp) =>+    (TypeConstraintsOf rowTyp -> TypeConstraintsOf valTyp) ->+    TypeConstraintsOf rowTyp ->+    RowExtend (RowKey rowTyp) valTyp rowTyp # h ->+    Maybe (RowExtend (RowKey rowTyp) valTyp rowTyp # WithConstraint h)+verifyRowExtendConstraints toChildC c (RowExtend h v rest)+    | c ^. forbidden . contains h = Nothing+    | otherwise =+        RowExtend h+        (WithConstraint (c & forbidden .~ mempty & toChildC) v)+        (WithConstraint (c & forbidden . contains h .~ True) rest)+        & Just++{-# INLINE rowExtendStructureMismatch #-}+rowExtendStructureMismatch ::+    Ord key =>+    ( Unify m rowTyp+    , Unify m valTyp+    ) =>+    (forall c. Unify m c => UVarOf m # c -> UVarOf m # c -> m (UVarOf m # c)) ->+    Prism' (rowTyp # UVarOf m) (RowExtend key valTyp rowTyp # UVarOf m) ->+    RowExtend key valTyp rowTyp # UVarOf m ->+    RowExtend key valTyp rowTyp # UVarOf m ->+    m ()+rowExtendStructureMismatch match extend r0 r1 =+    do+        flat0 <- flattenRowExtend nextExtend r0+        flat1 <- flattenRowExtend nextExtend r1+        Map.intersectionWith match (flat0 ^. freExtends) (flat1 ^. freExtends)+            & sequenceA_+        restVar <- UUnbound mempty & newVar binding+        let side x y =+                unflattenRow mkExtend FlatRowExtends+                { _freExtends =+                  (x ^. freExtends) `Map.difference` (y ^. freExtends)+                , _freRest = restVar+                } >>= match (y ^. freRest)+        _ <- side flat0 flat1+        _ <- side flat1 flat0+        pure ()+    where+        mkExtend ext = UTermBody mempty (extend # ext) & UTerm & newVar binding+        nextExtend v = semiPruneLookup v <&> (^? Lens._2 . _UTerm . uBody . extend)++-- Helper for infering row usages of a row element,+-- such as getting a field from a record or injecting into a sum type.+-- Returns a unification variable for the element and for the whole row.+{-# INLINE rowElementInfer #-}+rowElementInfer ::+    forall m valTyp rowTyp.+    ( UnifyGen m valTyp+    , UnifyGen m rowTyp+    , RowConstraints (TypeConstraintsOf rowTyp)+    ) =>+    (RowExtend (RowKey rowTyp) valTyp rowTyp # UVarOf m -> rowTyp # UVarOf m) ->+    RowKey rowTyp ->+    m (UVarOf m # valTyp, UVarOf m # rowTyp)+rowElementInfer extendToRow h =+    do+        restVar <-+            scopeConstraints (Proxy @rowTyp)+            >>= newVar binding . UUnbound . (forbidden . contains h .~ True)+        part <- newUnbound+        whole <- RowExtend h part restVar & extendToRow & newTerm+        pure (part, whole)
+ src/Hyper/Type/AST/Scheme.hs view
@@ -0,0 +1,268 @@+-- | Type schemes++{-# LANGUAGE TemplateHaskell, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}++module Hyper.Type.AST.Scheme+    ( Scheme(..), sForAlls, sTyp, W_Scheme(..)+    , QVars(..), _QVars+    , HasScheme(..), loadScheme, saveScheme+    , MonadInstantiate(..), inferType++    , QVarInstances(..), _QVarInstances+    , makeQVarInstances+    ) where++import qualified Control.Lens as Lens+import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.State (StateT(..))+import qualified Data.Map as Map+import           Hyper+import           Hyper.Class.Optic (HNodeLens(..))+import           Hyper.Infer+import           Hyper.Recurse+import           Hyper.Unify+import           Hyper.Unify.Generalize+import           Hyper.Unify.New (newTerm)+import           Hyper.Unify.QuantifiedVar (HasQuantifiedVar(..), MonadQuantify(..), OrdQVar)+import           Hyper.Unify.Term (UTerm(..), uBody)+import           Text.PrettyPrint ((<+>))+import qualified Text.PrettyPrint as Pretty+import           Text.PrettyPrint.HughesPJClass (Pretty(..), maybeParens)++import           Hyper.Internal.Prelude++-- | A type scheme representing a polymorphic type.+data Scheme varTypes typ h = Scheme+    { _sForAlls :: varTypes # QVars+    , _sTyp :: h :# typ+    } deriving Generic++newtype QVars typ = QVars+    (Map (QVar (GetHyperType typ)) (TypeConstraintsOf (GetHyperType typ)))+    deriving stock Generic++newtype QVarInstances h typ = QVarInstances (Map (QVar (GetHyperType typ)) (h typ))+    deriving stock Generic++makeLenses ''Scheme+makePrisms ''QVars+makePrisms ''QVarInstances+makeCommonInstances [''Scheme, ''QVars, ''QVarInstances]+makeHTraversableApplyAndBases ''Scheme++instance RNodes t => RNodes (Scheme v t)+instance (c (Scheme v t), Recursively c t) => Recursively c (Scheme v t)+instance (HTraversable (Scheme v t), RTraversable t) => RTraversable (Scheme v t)+instance (RTraversable t, RTraversableInferOf t) => RTraversableInferOf (Scheme v t)++instance+    ( Ord (QVar (GetHyperType typ))+    , Semigroup (TypeConstraintsOf (GetHyperType typ))+    ) =>+    Semigroup (QVars typ) where+    QVars m <> QVars n = QVars (Map.unionWith (<>) m n)++instance+    ( Ord (QVar (GetHyperType typ))+    , Semigroup (TypeConstraintsOf (GetHyperType typ))+    ) =>+    Monoid (QVars typ) where+    mempty = QVars mempty++instance+    (Pretty (varTypes # QVars), Pretty (h :# typ)) =>+    Pretty (Scheme varTypes typ h) where++    pPrintPrec lvl p (Scheme forAlls typ)+        | Pretty.isEmpty f = pPrintPrec lvl p typ+        | otherwise = f <+> pPrintPrec lvl 0 typ & maybeParens (p > 0)+        where+            f = pPrintPrec lvl 0 forAlls++instance+    (Pretty (TypeConstraintsOf typ), Pretty (QVar typ)) =>+    Pretty (QVars # typ) where++    pPrint (QVars qvars) =+        qvars ^@.. Lens.itraversed+        <&> printVar+        <&> (Pretty.text "∀" <>) <&> (<> Pretty.text ".") & Pretty.hsep+        where+            printVar (q, c)+                | cP == mempty = pPrint q+                | otherwise = pPrint q <> Pretty.text "(" <> cP <> Pretty.text ")"+                where+                    cP = pPrint c++type instance Lens.Index (QVars typ) = QVar (GetHyperType typ)+type instance Lens.IxValue (QVars typ) = TypeConstraintsOf (GetHyperType typ)++instance Ord (QVar (GetHyperType typ)) => Lens.Ixed (QVars typ)++instance Ord (QVar (GetHyperType typ)) => Lens.At (QVars typ) where+    at h = _QVars . Lens.at h++type instance InferOf (Scheme _ t) = HFlip GTerm t++class UnifyGen m t => MonadInstantiate m t where+    localInstantiations ::+        QVarInstances (UVarOf m) # t ->+        m a ->+        m a+    lookupQVar :: QVar t -> m (UVarOf m # t)++instance+    ( Monad m+    , HasInferredValue typ+    , UnifyGen m typ+    , HTraversable varTypes+    , HNodesConstraint varTypes (MonadInstantiate m)+    , RTraversable typ+    , Infer m typ+    ) =>+    Infer m (Scheme varTypes typ) where++    {-# INLINE inferBody #-}+    inferBody (Scheme vars typ) =+        do+            foralls <- htraverse (Proxy @(MonadInstantiate m) #> makeQVarInstances) vars+            let withForalls =+                    hfoldMap+                    (Proxy @(MonadInstantiate m) #> (:[]) . localInstantiations)+                    foralls+                    & foldl (.) id+            InferredChild typI typR <- inferChild typ & withForalls+            generalize (typR ^. inferredValue)+                <&> (Scheme vars typI, ) . MkHFlip++inferType ::+    ( InferOf t ~ ANode t+    , HTraversable t+    , HNodesConstraint t HasInferredValue+    , UnifyGen m t+    , MonadInstantiate m t+    ) =>+    t # InferChild m h ->+    m (t # h, InferOf t # UVarOf m)+inferType x =+    case x ^? quantifiedVar of+    Just q -> lookupQVar q <&> (quantifiedVar # q, ) . MkANode+    Nothing ->+        do+            xI <- htraverse (const inferChild) x+            hmap (Proxy @HasInferredValue #> (^. inType . inferredValue)) xI+                & newTerm+                <&> (hmap (const (^. inRep)) xI, ) . MkANode++{-# INLINE makeQVarInstances #-}+makeQVarInstances ::+    Unify m typ =>+    QVars # typ -> m (QVarInstances (UVarOf m) # typ)+makeQVarInstances (QVars foralls) =+    traverse (newVar binding . USkolem) foralls <&> QVarInstances++{-# INLINE loadBody #-}+loadBody ::+    ( UnifyGen m typ+    , HNodeLens varTypes typ+    , Ord (QVar typ)+    ) =>+    varTypes # QVarInstances (UVarOf m) ->+    typ # GTerm (UVarOf m) ->+    m (GTerm (UVarOf m) # typ)+loadBody foralls x =+    case x ^? quantifiedVar >>= getForAll of+    Just r -> GPoly r & pure+    Nothing ->+        case htraverse (const (^? _GMono)) x of+        Just xm -> newTerm xm <&> GMono+        Nothing -> GBody x & pure+    where+        getForAll v = foralls ^? hNodeLens . _QVarInstances . Lens.ix v++class+    (UnifyGen m t, HNodeLens varTypes t, Ord (QVar t)) =>+    HasScheme varTypes m t where++    hasSchemeRecursive ::+        Proxy varTypes -> Proxy m -> Proxy t ->+        Dict (HNodesConstraint t (HasScheme varTypes m))+    {-# INLINE hasSchemeRecursive #-}+    default hasSchemeRecursive ::+        HNodesConstraint t (HasScheme varTypes m) =>+        Proxy varTypes -> Proxy m -> Proxy t ->+        Dict (HNodesConstraint t (HasScheme varTypes m))+    hasSchemeRecursive _ _ _ = Dict++instance Recursive (HasScheme varTypes m) where+    recurse = hasSchemeRecursive (Proxy @varTypes) (Proxy @m) . proxyArgument++-- | Load scheme into unification monad so that different instantiations share+-- the scheme's monomorphic parts -+-- their unification is O(1) as it is the same shared unification term.+{-# INLINE loadScheme #-}+loadScheme ::+    forall m varTypes typ.+    ( Monad m+    , HTraversable varTypes+    , HNodesConstraint varTypes (UnifyGen m)+    , HasScheme varTypes m typ+    ) =>+    Pure # Scheme varTypes typ ->+    m (GTerm (UVarOf m) # typ)+loadScheme (Pure (Scheme vars typ)) =+    do+        foralls <- htraverse (Proxy @(UnifyGen m) #> makeQVarInstances) vars+        wrapM (Proxy @(HasScheme varTypes m) #>> loadBody foralls) typ++saveH ::+    forall typ varTypes m.+    (Monad m, HasScheme varTypes m typ) =>+    GTerm (UVarOf m) # typ ->+    StateT (varTypes # QVars, [m ()]) m (Pure # typ)+saveH (GBody x) =+    withDict (hasSchemeRecursive (Proxy @varTypes) (Proxy @m) (Proxy @typ)) $+    htraverse (Proxy @(HasScheme varTypes m) #> saveH) x <&> (_Pure #)+saveH (GMono x) =+    unwrapM (Proxy @(HasScheme varTypes m) #>> f) x & lift+    where+        f v =+            semiPruneLookup v+            <&>+            \case+            (_, UTerm t) -> t ^. uBody+            (_, UUnbound{}) -> error "saveScheme of non-toplevel scheme!"+            _ -> error "unexpected state at saveScheme of monomorphic part"+saveH (GPoly x) =+    lookupVar binding x & lift+    >>=+    \case+    USkolem l ->+        do+            r <-+                scopeConstraints (Proxy @typ) <&> (<> l)+                >>= newQuantifiedVariable & lift+            Lens._1 . hNodeLens %=+                (\v -> v & _QVars . Lens.at r ?~ generalizeConstraints l :: QVars # typ)+            Lens._2 %= (bindVar binding x (USkolem l) :)+            let result = _Pure . quantifiedVar # r+            UResolved result & bindVar binding x & lift+            pure result+    UResolved v -> pure v+    _ -> error "unexpected state at saveScheme's forall"++saveScheme ::+    ( HNodesConstraint varTypes OrdQVar+    , HPointed varTypes+    , HasScheme varTypes m typ+    ) =>+    GTerm (UVarOf m) # typ ->+    m (Pure # Scheme varTypes typ)+saveScheme x =+    do+        (t, (v, recover)) <-+            runStateT (saveH x)+            ( hpure (Proxy @OrdQVar #> QVars mempty)+            , []+            )+        _Pure # Scheme v t <$ sequence_ recover
+ src/Hyper/Type/AST/Scheme/AlphaEq.hs view
@@ -0,0 +1,112 @@+-- | Alpha-equality for schemes+{-# LANGUAGE FlexibleContexts #-}++module Hyper.Type.AST.Scheme.AlphaEq+    ( alphaEq+    ) where++import Control.Lens (ix)+import Hyper+import Hyper.Class.Optic (HNodeLens(..))+import Hyper.Class.ZipMatch (zipMatch_)+import Hyper.Recurse (wrapM, (#>>))+import Hyper.Type.AST.Scheme+import Hyper.Unify+import Hyper.Unify.New (newTerm)+import Hyper.Unify.QuantifiedVar+import Hyper.Unify.Term (UTerm(..), uBody)++import Hyper.Internal.Prelude++makeQVarInstancesInScope ::+    forall m typ.+    UnifyGen m typ =>+    QVars # typ -> m (QVarInstances (UVarOf m) # typ)+makeQVarInstancesInScope (QVars foralls) =+    traverse makeSkolem foralls <&> QVarInstances+    where+        makeSkolem c = scopeConstraints (Proxy @typ) >>= newVar binding . USkolem . (c <>)++schemeBodyToType ::+    (UnifyGen m typ, HNodeLens varTypes typ, Ord (QVar typ)) =>+    varTypes # QVarInstances (UVarOf m) -> typ # UVarOf m -> m (UVarOf m # typ)+schemeBodyToType foralls x =+    case x ^? quantifiedVar >>= getForAll of+    Nothing -> newTerm x+    Just r -> pure r+    where+        getForAll v = foralls ^? hNodeLens . _QVarInstances . ix v++schemeToRestrictedType ::+    forall m varTypes typ.+    ( Monad m+    , HTraversable varTypes+    , HNodesConstraint varTypes (UnifyGen m)+    , HasScheme varTypes m typ+    ) =>+    Pure # Scheme varTypes typ -> m (UVarOf m # typ)+schemeToRestrictedType (Pure (Scheme vars typ)) =+    do+        foralls <- htraverse (Proxy @(UnifyGen m) #> makeQVarInstancesInScope) vars+        wrapM (Proxy @(HasScheme varTypes m) #>> schemeBodyToType foralls) typ++goUTerm ::+    forall m t.+    Unify m t =>+    UVarOf m # t -> UTerm (UVarOf m) # t ->+    UVarOf m # t -> UTerm (UVarOf m) # t ->+    m ()+goUTerm xv USkolem{} yv USkolem{} =+    do+        bindVar binding xv (UInstantiated yv)+        bindVar binding yv (UInstantiated xv)+goUTerm xv (UInstantiated xt) yv (UInstantiated yt)+    | xv == yt && yv == xt = pure ()+    | otherwise = unifyError (SkolemEscape xv)+goUTerm xv USkolem{} yv UUnbound{} = bindVar binding yv (UToVar xv)+goUTerm xv UUnbound{} yv USkolem{} = bindVar binding xv (UToVar yv)+goUTerm xv UInstantiated{} yv UUnbound{} = bindVar binding yv (UToVar xv)+goUTerm xv UUnbound{} yv UInstantiated{} = bindVar binding xv (UToVar yv)+goUTerm _ (UToVar xv) yv yu =+    do+        xu <- lookupVar binding xv+        goUTerm xv xu yv yu+goUTerm xv xu _ (UToVar yv) =+    do+        yu <- lookupVar binding yv+        goUTerm xv xu yv yu+goUTerm xv USkolem{} yv _ = unifyError (SkolemUnified xv yv)+goUTerm xv _ yv USkolem{} = unifyError (SkolemUnified yv xv)+goUTerm xv UInstantiated{} yv _ = unifyError (SkolemUnified xv yv)+goUTerm xv _ yv UInstantiated{} = unifyError (SkolemUnified yv xv)+goUTerm xv UUnbound{} yv yu = goUTerm xv yu yv yu -- Term created in structure mismatch+goUTerm xv xu yv UUnbound{} = goUTerm xv xu yv xu -- Term created in structure mismatch+goUTerm _ (UTerm xt) _ (UTerm yt) =+    withDict (unifyRecursive (Proxy @m) (Proxy @t)) $+    zipMatch_ (Proxy @(Unify m) #> goUVar) (xt ^. uBody) (yt ^. uBody)+    & fromMaybe (structureMismatch (\x y -> x <$ goUVar x y) (xt ^. uBody) (yt ^. uBody))+goUTerm _ _ _ _ = error "unexpected state at alpha-eq"++goUVar ::+    Unify m t =>+    UVarOf m # t -> UVarOf m # t -> m ()+goUVar xv yv =+    do+        xu <- lookupVar binding xv+        yu <- lookupVar binding yv+        goUTerm xv xu yv yu++-- Check for alpha equality. Raises a `unifyError` when mismatches.+alphaEq ::+    ( HTraversable varTypes+    , HNodesConstraint varTypes (UnifyGen m)+    , HasScheme varTypes m typ+    ) =>+    Pure # Scheme varTypes typ ->+    Pure # Scheme varTypes typ ->+    m ()+alphaEq s0 s1 =+    do+        t0 <- schemeToRestrictedType s0+        t1 <- schemeToRestrictedType s1+        goUVar t0 t1
+ src/Hyper/Type/AST/TypeSig.hs view
@@ -0,0 +1,61 @@+-- | Type signatures++{-# LANGUAGE UndecidableInstances, TemplateHaskell, FlexibleInstances #-}++module Hyper.Type.AST.TypeSig+    ( TypeSig(..), tsType, tsTerm, W_TypeSig(..)+    ) where++import           Generics.Constraints (Constraints)+import           Hyper+import           Hyper.Infer+import           Hyper.Type.AST.Scheme+import           Hyper.Unify (UnifyGen, unify)+import           Hyper.Unify.Generalize (instantiateWith)+import           Hyper.Unify.Term (UTerm(..))+import           Text.PrettyPrint ((<+>))+import qualified Text.PrettyPrint as Pretty+import           Text.PrettyPrint.HughesPJClass (Pretty(..), maybeParens)++import           Hyper.Internal.Prelude++data TypeSig vars term h = TypeSig+    { _tsTerm :: h :# term+    , _tsType :: h :# Scheme vars (TypeOf term)+    } deriving Generic++makeLenses ''TypeSig+makeCommonInstances [''TypeSig]+makeHTraversableApplyAndBases ''TypeSig++instance+    Constraints (TypeSig vars term h) Pretty =>+    Pretty (TypeSig vars term h) where+    pPrintPrec lvl p (TypeSig term typ) =+        pPrintPrec lvl 1 term <+> Pretty.text ":" <+> pPrintPrec lvl 1 typ+        & maybeParens (p > 1)++type instance InferOf (TypeSig _ t) = InferOf t++instance+    ( MonadScopeLevel m+    , HasInferredType term+    , HasInferredValue (TypeOf term)+    , HTraversable vars+    , HTraversable (InferOf term)+    , HNodesConstraint (InferOf term) (UnifyGen m)+    , HNodesConstraint vars (MonadInstantiate m)+    , UnifyGen m (TypeOf term)+    , Infer m (TypeOf term)+    , Infer m term+    ) =>+    Infer m (TypeSig vars term) where++    inferBody (TypeSig x s) =+        do+            InferredChild xI xR <- inferChild x+            InferredChild sI sR <- inferChild s+            (t, ()) <- instantiateWith (pure ()) USkolem (sR ^. _HFlip)+            xR & inferredType (Proxy @term) #%%~ unify t+                <&> (TypeSig xI sI, )+        & localLevel
+ src/Hyper/Type/AST/TypedLam.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TemplateHaskell, UndecidableInstances, FlexibleInstances #-}++module Hyper.Type.AST.TypedLam+    ( TypedLam(..), tlIn, tlInType, tlOut, W_TypedLam(..), MorphWitness(..)+    ) where++import           Generics.Constraints (Constraints)+import           Hyper+import           Hyper.Class.Optic (HNodeLens(..), HSubset(..), HSubset')+import           Hyper.Infer+import           Hyper.Type.AST.FuncType (FuncType(..))+import           Hyper.Unify (UnifyGen, UVarOf)+import           Hyper.Unify.New (newTerm)+import qualified Text.PrettyPrint as P+import           Text.PrettyPrint.HughesPJClass (Pretty(..), maybeParens)++import           Hyper.Internal.Prelude++data TypedLam var typ expr h = TypedLam+    { _tlIn :: var+    , _tlInType :: h :# typ+    , _tlOut :: h :# expr+    } deriving Generic++makeLenses ''TypedLam+makeCommonInstances [''TypedLam]+makeHTraversableApplyAndBases ''TypedLam+makeZipMatch ''TypedLam+makeHContext ''TypedLam+makeHMorph ''TypedLam++instance (RNodes t, RNodes e) => RNodes (TypedLam v t e)+instance+    (c (TypedLam v t e), Recursively c t, Recursively c e) =>+    Recursively c (TypedLam v t e)+instance (RTraversable t, RTraversable e) => RTraversable (TypedLam v t e)++instance+    Constraints (TypedLam var typ expr h) Pretty =>+    Pretty (TypedLam var typ expr h) where+    pPrintPrec lvl p (TypedLam i t o) =+        ( P.text "λ" <> pPrintPrec lvl 0 i+            <> P.text ":" <> pPrintPrec lvl 0 t+        ) P.<+> P.text "→" P.<+> pPrintPrec lvl 0 o+        & maybeParens (p > 0)++type instance InferOf (TypedLam _ _ e) = ANode (TypeOf e)++instance+    ( Infer m t+    , Infer m e+    , HasInferredType e+    , UnifyGen m (TypeOf e)+    , HSubset' (TypeOf e) (FuncType (TypeOf e))+    , HNodeLens (InferOf t) (TypeOf e)+    , LocalScopeType v (UVarOf m # TypeOf e) m+    ) =>+    Infer m (TypedLam v t e) where++    {-# INLINE inferBody #-}+    inferBody (TypedLam p t r) =+        do+            InferredChild tI tR <- inferChild t+            let tT = tR ^. hNodeLens+            InferredChild rI rR <- inferChild r & localScopeType p tT+            hSubset # FuncType tT (rR ^# inferredType (Proxy @e))+                & newTerm+                <&> MkANode+                <&> (TypedLam p tI rI,)
+ src/Hyper/Type/AST/Var.hs view
@@ -0,0 +1,64 @@+-- | Variables.++{-# LANGUAGE UndecidableInstances, EmptyCase #-}+{-# LANGUAGE FlexibleInstances, TemplateHaskell, FlexibleContexts #-}++module Hyper.Type.AST.Var+    ( Var(..), _Var+    , VarType(..)+    , ScopeOf, HasScope(..)+    ) where++import Hyper+import Hyper.Infer+import Hyper.Unify (UnifyGen, UVarOf)+import Text.PrettyPrint.HughesPJClass (Pretty(..))++import Hyper.Internal.Prelude++type family ScopeOf (t :: HyperType) :: HyperType++class HasScope m s where+    getScope :: m (s # UVarOf m)++class VarType var expr where+    -- | Instantiate a type for a variable in a given scope+    varType ::+        UnifyGen m (TypeOf expr) =>+        Proxy expr -> var -> ScopeOf expr # UVarOf m ->+        m (UVarOf m # TypeOf expr)++-- | Parameterized by term AST and not by its type AST+-- (which currently is its only part used),+-- for future evaluation/complilation support.+newtype Var v (expr :: HyperType) (h :: AHyperType) = Var v+    deriving newtype (Eq, Ord, Binary, NFData)+    deriving stock (Show, Generic)++makePrisms ''Var+makeHTraversableApplyAndBases ''Var+makeZipMatch ''Var+makeHContext ''Var+makeHMorph ''Var++instance Pretty v => Pretty (Var v expr h) where+    pPrintPrec lvl p (Var v) = pPrintPrec lvl p v++type instance InferOf (Var _ t) = ANode (TypeOf t)++instance HasInferredType (Var v t) where+    type instance (TypeOf (Var v t)) = TypeOf t+    {-# INLINE inferredType #-}+    inferredType _ = _ANode++instance+    ( UnifyGen m (TypeOf expr)+    , HasScope m (ScopeOf expr)+    , VarType v expr+    , Monad m+    ) =>+    Infer m (Var v expr) where++    {-# INLINE inferBody #-}+    inferBody (Var x) =+        getScope >>= varType (Proxy @expr) x <&> MkANode <&> (Var x, )
+ src/Hyper/Type/Functor.hs view
@@ -0,0 +1,55 @@+-- | Lift Functors to HyperTypes+{-# LANGUAGE TemplateHaskell, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+module Hyper.Type.Functor+    ( F(..), _F, W_F(..)+    ) where++import Control.Lens (iso, mapped)+import Hyper+import Hyper.Class.Monad (HMonad(..))++import Hyper.Internal.Prelude++-- | Lift a 'Functor', or type constructor of kind @Type -> Type@ to a 'Hyper.Type.HyperType'.+--+-- * @F Maybe@ can be used to encode structures with missing values+-- * @F (Either Text)@ can be used to encode results of parsing where structure components+--   may fail to parse.+newtype F f h = F (f (h :# F f))+    deriving stock Generic++-- | An 'Iso' from 'F' to its content.+--+-- Using `_F` rather than the 'F' data constructor is recommended,+-- because it helps the type inference know that @F f@ is parameterized with a 'Hyper.Type.HyperType'.+_F ::+    Iso (F f0 # k0)+        (F f1 # k1)+        (f0 (k0 # F f0))+        (f1 (k1 # F f1))+_F = iso (\(F x) -> x) F++makeCommonInstances [''F]+makeHTraversableApplyAndBases ''F++instance Monad f => HMonad (F f) where+    hjoin =+        ( _F %~+            ( >>=+                ( mapped %~ t . (^. _HCompose)+                ) . (^. _HCompose . _F)+            )+        ) . (^. _HCompose)+        where+            t ::+                forall p.+                Recursively HFunctor p =>+                p # HCompose (F f) (F f) ->+                p # F f+            t =+                withDict (recursively (Proxy @(HFunctor p))) $+                hmap (Proxy @(Recursively HFunctor) #> hjoin)++instance RNodes (F f)+instance c (F f) => Recursively c (F f)+instance Traversable f => RTraversable (F f)
+ src/Hyper/Type/Prune.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE UndecidableInstances, TemplateHaskell, FlexibleInstances #-}++module Hyper.Type.Prune+    ( Prune(..), W_Prune(..), _Pruned, _Unpruned+    ) where++import qualified Control.Lens as Lens+import           Hyper+import           Hyper.Class.Traversable+import           Hyper.Class.Unify (UnifyGen)+import           Hyper.Combinator.Compose (HComposeConstraint1)+import           Hyper.Infer+import           Hyper.Infer.Blame (Blame(..))+import           Hyper.Unify.New (newUnbound)++import           Hyper.Internal.Prelude++data Prune h =+    Pruned | Unpruned (h :# Prune)+    deriving Generic++makeCommonInstances [''Prune]+makePrisms ''Prune+makeHTraversableAndBases ''Prune+makeZipMatch ''Prune+makeHContext ''Prune++-- `HPointed` and `HApplicative` instances in the spirit of `Maybe`++instance HPointed Prune where+    hpure f = Unpruned (f (HWitness W_Prune_Prune))++instance HApply Prune where+    hzip Pruned _ = Pruned+    hzip _ Pruned = Pruned+    hzip (Unpruned x) (Unpruned y) = x :*: y & Unpruned++instance RNodes Prune+instance c Prune => Recursively c Prune+instance RTraversable Prune++type instance InferOf (HCompose Prune t) = InferOf t++instance+    ( Infer m t+    , HPointed (InferOf t)+    , HTraversable (InferOf t)+    , HNodesConstraint t (HComposeConstraint1 (Infer m) Prune)+    ) =>+    Infer m (HCompose Prune t) where+    inferBody (HCompose Pruned) =+        withDict (inferContext (Proxy @m) (Proxy @t)) $+        hpure (Proxy @(UnifyGen m) #> MkContainedH newUnbound)+        & hsequence+        <&> (_HCompose # Pruned, )+    inferBody (HCompose (Unpruned (HCompose x))) =+        hmap+        ( \_ (HCompose (InferChild i)) ->+            i <&> (\(InferredChild r t) -> InferredChild (_HCompose # r) t)+            & InferChild+        ) x+        & inferBody+        <&> Lens._1 %~ (hcomposed _Unpruned #)+    inferContext m _ = withDict (inferContext m (Proxy @t)) Dict++instance+    ( Blame m t+    , HNodesConstraint t (HComposeConstraint1 (Infer m) Prune)+    , HNodesConstraint t (HComposeConstraint1 (Blame m) Prune)+    , HNodesConstraint t (HComposeConstraint1 RNodes Prune)+    , HNodesConstraint t (HComposeConstraint1 (Recursively HFunctor) Prune)+    , HNodesConstraint t (HComposeConstraint1 (Recursively HFoldable) Prune)+    , HNodesConstraint t (HComposeConstraint1 RTraversable Prune)+    ) =>+    Blame m (HCompose Prune t) where+    inferOfUnify _ = inferOfUnify (Proxy @t)+    inferOfMatches _ = inferOfMatches (Proxy @t)
+ src/Hyper/Type/Pure.hs view
@@ -0,0 +1,35 @@+-- | A 'Hyper.Type.HyperType' to express the simplest plain form of a nested higher-kinded data structure.+--+-- The value level [hyperfunctions](http://hackage.haskell.org/package/hyperfunctions)+-- equivalent of 'Pure' is called @self@ in+-- [Hyperfunctions papers](https://arxiv.org/abs/1309.5135).++{-# LANGUAGE UndecidableInstances, TemplateHaskell #-}+module Hyper.Type.Pure+    ( Pure(..), _Pure, W_Pure(..)+    ) where++import Control.Lens (iso)+import Hyper.TH.Traversable (makeHTraversableApplyAndBases)+import Hyper.Type (type (#), type (:#))+import Text.PrettyPrint.HughesPJClass (Pretty(..))++import Hyper.Internal.Prelude++-- | A 'Hyper.Type.HyperType' to express the simplest plain form of a nested higher-kinded data structure+newtype Pure h = Pure (h :# Pure)+    deriving stock Generic++makeHTraversableApplyAndBases ''Pure+makeCommonInstances [''Pure]++-- | An 'Iso' from 'Pure' to its content.+--+-- Using `_Pure` rather than the 'Pure' data constructor is recommended,+-- because it helps the type inference know that 'Pure' is parameterized with a 'Hyper.Type.HyperType'.+{-# INLINE _Pure #-}+_Pure :: Iso (Pure # h) (Pure # j) (h # Pure) (j # Pure)+_Pure = iso (\(Pure x) -> x) Pure++instance Pretty (h :# Pure) => Pretty (Pure h) where+    pPrintPrec lvl p (Pure x) = pPrintPrec lvl p x
+ src/Hyper/Unify.hs view
@@ -0,0 +1,132 @@+-- | Unification++{-# LANGUAGE BangPatterns #-}++module Hyper.Unify+    ( unify+    , module Hyper.Class.Unify+    , module Hyper.Unify.Binding+    , module Hyper.Unify.Constraints+    , module Hyper.Unify.Error++    , -- | Exported only for SPECIALIZE pragmas+      updateConstraints, updateTermConstraints, updateTermConstraintsH+    , unifyUTerms, unifyUnbound+    ) where++import Algebra.PartialOrd (PartialOrd(..))+import Hyper+import Hyper.Class.Unify+import Hyper.Class.ZipMatch (zipMatchA)+import Hyper.Unify.Binding (UVar)+import Hyper.Unify.Constraints+import Hyper.Unify.Error (UnifyError(..))+import Hyper.Unify.Term (UTerm(..), UTermBody(..), uConstraints, uBody)++import Hyper.Internal.Prelude++-- TODO: implement when need / better understand motivations for -+-- occursIn, seenAs, getFreeVars, freshen, equals, equiv+-- (from unification-fd package)++{-# INLINE updateConstraints #-}+updateConstraints ::+    Unify m t =>+    TypeConstraintsOf t ->+    UVarOf m # t ->+    UTerm (UVarOf m) # t ->+    m ()+updateConstraints !newConstraints v x =+    case x of+    UUnbound l+        | newConstraints `leq` l -> pure ()+        | otherwise -> bindVar binding v (UUnbound newConstraints)+    USkolem l+        | newConstraints `leq` l -> pure ()+        | otherwise -> SkolemEscape v & unifyError+    UTerm t -> updateTermConstraints v t newConstraints+    UResolving t -> () <$ occursError v t+    _ -> error "This shouldn't happen in unification stage"++{-# INLINE updateTermConstraints #-}+updateTermConstraints ::+    forall m t.+    Unify m t =>+    UVarOf m # t ->+    UTermBody (UVarOf m) # t ->+    TypeConstraintsOf t ->+    m ()+updateTermConstraints v t newConstraints+    | newConstraints `leq` (t ^. uConstraints) = pure ()+    | otherwise =+        withDict (unifyRecursive (Proxy @m) (Proxy @t)) $+        do+            bindVar binding v (UResolving t)+            case verifyConstraints newConstraints (t ^. uBody) of+                Nothing -> ConstraintsViolation (t ^. uBody) newConstraints & unifyError+                Just prop ->+                    do+                        htraverse_ (Proxy @(Unify m) #> updateTermConstraintsH) prop+                        UTermBody newConstraints (t ^. uBody) & UTerm & bindVar binding v++{-# INLINE updateTermConstraintsH #-}+updateTermConstraintsH ::+    Unify m t =>+    WithConstraint (UVarOf m) # t ->+    m ()+updateTermConstraintsH (WithConstraint c v0) =+    do+        (v1, x) <- semiPruneLookup v0+        updateConstraints c v1 x++-- | Unify unification variables+{-# INLINE unify #-}+unify ::+    forall m t.+    Unify m t =>+    UVarOf m # t -> UVarOf m # t -> m (UVarOf m # t)+unify x0 y0+    | x0 == y0 = pure x0+    | otherwise =+        do+            (x1, xu) <- semiPruneLookup x0+            if x1 == y0+                then pure x1+                else+                    do+                        (y1, yu) <- semiPruneLookup y0+                        if x1 == y1+                            then pure x1+                            else unifyUTerms x1 xu y1 yu++{-# INLINE unifyUnbound #-}+unifyUnbound ::+    Unify m t =>+    UVarOf m # t -> TypeConstraintsOf t ->+    UVarOf m # t -> UTerm (UVarOf m) # t ->+    m (UVarOf m # t)+unifyUnbound xv level yv yt =+    do+        updateConstraints level yv yt+        yv <$ bindVar binding xv (UToVar yv)++{-# INLINE unifyUTerms #-}+unifyUTerms ::+    forall m t.+    Unify m t =>+    UVarOf m # t -> UTerm (UVarOf m) # t ->+    UVarOf m # t -> UTerm (UVarOf m) # t ->+    m (UVarOf m # t)+unifyUTerms xv (UUnbound level) yv yt = unifyUnbound xv level yv yt+unifyUTerms xv xt yv (UUnbound level) = unifyUnbound yv level xv xt+unifyUTerms xv USkolem{} yv _ = xv <$ unifyError (SkolemUnified xv yv)+unifyUTerms xv _ yv USkolem{} = yv <$ unifyError (SkolemUnified yv xv)+unifyUTerms xv (UTerm xt) yv (UTerm yt) =+    withDict (unifyRecursive (Proxy @m) (Proxy @t)) $+    do+        bindVar binding yv (UToVar xv)+        zipMatchA (Proxy @(Unify m) #> unify) (xt ^. uBody) (yt ^. uBody)+            & fromMaybe (xt ^. uBody <$ structureMismatch unify (xt ^. uBody) (yt ^. uBody))+            >>= bindVar binding xv . UTerm . UTermBody (xt ^. uConstraints <> yt ^. uConstraints)+        pure xv+unifyUTerms _ _ _ _ = error "This shouldn't happen in unification stage"
+ src/Hyper/Unify/Binding.hs view
@@ -0,0 +1,58 @@+-- | A pure data structures implementation of unification variables state++{-# LANGUAGE UndecidableInstances, TemplateHaskell #-}++module Hyper.Unify.Binding+    ( UVar(..), _UVar+    , Binding(..), _Binding+    , emptyBinding+    , bindingDict+    ) where++import           Control.Lens (ALens')+import qualified Control.Lens as Lens+import           Control.Monad.State (MonadState(..))+import           Data.Sequence (Seq)+import           Hyper.Class.Unify (BindingDict(..))+import           Hyper.Type (AHyperType, type (#))+import           Hyper.Unify.Term++import           Hyper.Internal.Prelude++-- | A unification variable identifier pure state based unification+newtype UVar (t :: AHyperType) = UVar Int+    deriving stock (Generic, Show)+    deriving newtype (Eq, Ord)+makePrisms ''UVar++-- | The state of unification variables implemented in a pure data structure+newtype Binding t = Binding (Seq (UTerm UVar t))+    deriving stock Generic++makePrisms ''Binding+makeCommonInstances [''Binding]++-- | An empty 'Binding'+emptyBinding :: Binding t+emptyBinding = Binding mempty++-- | A 'BindingDict' for 'UVar's in a 'MonadState' whose state contains a 'Binding'+{-# INLINE bindingDict #-}+bindingDict ::+    MonadState s m =>+    ALens' s (Binding # t) ->+    BindingDict UVar m t+bindingDict l =+    BindingDict+    { lookupVar =+        \(UVar h) ->+        Lens.use (Lens.cloneLens l . _Binding)+        <&> (^?! Lens.ix h)+    , newVar =+        \x ->+        Lens.cloneLens l . _Binding <<%= (Lens.|> x)+        <&> length <&> UVar+    , bindVar =+        \(UVar h) v ->+        Lens.cloneLens l . _Binding . Lens.ix h .= v+    }
+ src/Hyper/Unify/Binding/ST.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Unification variables binding in the 'Control.Monad.ST.ST' monad++module Hyper.Unify.Binding.ST+    ( STUVar(..), _STUVar+    , stBinding+    ) where++import           Control.Monad.ST.Class (MonadST(..))+import           Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)+import           Hyper.Class.Unify (BindingDict(..))+import           Hyper.Unify.Term (UTerm(..))++import           Hyper.Internal.Prelude++-- | A unification variable in the 'Control.Monad.ST.ST' monad+newtype STUVar s t = STUVar (STRef s (UTerm (STUVar s) t))+    deriving stock Eq+makePrisms ''STUVar++-- | A 'BindingDict' for 'STUVar's+{-# INLINE stBinding #-}+stBinding ::+    MonadST m =>+    BindingDict (STUVar (World m)) m t+stBinding =+    BindingDict+    { lookupVar = liftST . readSTRef . (^. _STUVar)+    , newVar = \t -> newSTRef t & liftST <&> STUVar+    , bindVar = \v t -> writeSTRef (v ^. _STUVar) t & liftST+    }
+ src/Hyper/Unify/Binding/ST/Load.hs view
@@ -0,0 +1,103 @@+-- | Load serialized a binding state to 'Control.Monad.ST.ST' based bindings++{-# LANGUAGE TemplateHaskell, FlexibleContexts #-}++module Hyper.Unify.Binding.ST.Load+    ( load+    ) where++import qualified Control.Lens as Lens+import           Control.Monad.ST.Class (MonadST(..))+import           Data.Array.ST (STArray, newArray, readArray, writeArray)+import           Hyper+import           Hyper.Class.Optic (HNodeLens(..))+import           Hyper.Class.Unify (Unify(..), UVarOf, BindingDict(..))+import           Hyper.Recurse+import           Hyper.Unify.Binding (Binding(..), _Binding, UVar(..))+import           Hyper.Unify.Binding.ST (STUVar)+import           Hyper.Unify.Term (UTerm(..), uBody)++import           Hyper.Internal.Prelude++newtype ConvertState s t = ConvertState (STArray s Int (Maybe (STUVar s t)))+makePrisms ''ConvertState++makeConvertState :: MonadST m => Binding # t -> m (ConvertState (World m) # t)+makeConvertState (Binding x) =+    newArray (0, length x) Nothing & liftST <&> ConvertState++loadUTerm ::+    forall m typeVars t.+    ( MonadST m+    , UVarOf m ~ STUVar (World m)+    , Unify m t+    , Recursively (HNodeLens typeVars) t+    ) =>+    typeVars # Binding -> typeVars # ConvertState (World m) ->+    UTerm UVar # t -> m (UTerm (STUVar (World m)) # t)+loadUTerm _ _ (UUnbound c) = UUnbound c & pure+loadUTerm _ _ (USkolem c) = USkolem c & pure+loadUTerm src conv (UToVar v) = loadVar src conv v <&> UToVar+loadUTerm src conv (UTerm u) = uBody (loadBody src conv) u <&> UTerm+loadUTerm _ _ UResolving{} = error "converting bindings after resolution"+loadUTerm _ _ UResolved{} = error "converting bindings after resolution"+loadUTerm _ _ UConverted{} = error "loading while saving?"+loadUTerm _ _ UInstantiated{} = error "loading during instantiation"++loadVar ::+    forall m t typeVars.+    ( MonadST m+    , UVarOf m ~ STUVar (World m)+    , Unify m t+    , Recursively (HNodeLens typeVars) t+    ) =>+    typeVars # Binding -> typeVars # ConvertState (World m) ->+    UVar # t -> m (STUVar (World m) # t)+loadVar src conv (UVar v) =+    withDict (recursively (Proxy @(HNodeLens typeVars t))) $+    let tConv = conv ^. hNodeLens . _ConvertState+    in+    readArray tConv v & liftST+    >>=+    \case+    Just x -> pure x+    Nothing ->+        do+            u <-+                loadUTerm src conv+                (src ^?! hNodeLens . _Binding . Lens.ix v)+            r <- newVar binding u+            r <$ liftST (writeArray tConv v (Just r))++loadBody ::+    forall m typeVars t.+    ( MonadST m+    , UVarOf m ~ STUVar (World m)+    , Unify m t+    , Recursively (HNodeLens typeVars) t+    ) =>+    typeVars # Binding -> typeVars # ConvertState (World m) ->+    t # UVar -> m (t # STUVar (World m))+loadBody src conv =+    withDict (recurse (Proxy @(Unify m t))) $+    withDict (recursively (Proxy @(HNodeLens typeVars t))) $+    htraverse+    ( Proxy @(Unify m) #*# Proxy @(Recursively (HNodeLens typeVars))+        #> loadVar src conv+    )++-- | Load a given serialized unification+-- and a value with serialized unification variable identifiers+-- to a value with 'Control.Monad.ST.ST' unification variables.+load ::+    ( MonadST m+    , UVarOf m ~ STUVar (World m)+    , HTraversable typeVars+    , Unify m t+    , Recursively (HNodeLens typeVars) t+    ) =>+    typeVars # Binding -> t # UVar -> m (t #STUVar (World m))+load src collection =+    do+        conv <- htraverse (const makeConvertState) src+        loadBody src conv collection
+ src/Hyper/Unify/Binding/Save.hs view
@@ -0,0 +1,82 @@+-- | Serialize the state of unification++{-# LANGUAGE FlexibleContexts #-}++module Hyper.Unify.Binding.Save+    ( save+    ) where++import qualified Control.Lens as Lens+import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.State (StateT(..))+import           Hyper+import           Hyper.Class.Optic (HNodeLens(..))+import           Hyper.Class.Unify (Unify(..), UVarOf, BindingDict(..))+import           Hyper.Recurse+import           Hyper.Unify.Binding (Binding, _Binding, UVar(..))+import           Hyper.Unify.Term (UTerm(..), uBody)++import           Hyper.Internal.Prelude++saveUTerm ::+    forall m typeVars t.+    (Unify m t, Recursively (HNodeLens typeVars) t) =>+    UTerm (UVarOf m) # t ->+    StateT (typeVars # Binding, [m ()]) m (UTerm UVar # t)+saveUTerm (UUnbound c) = UUnbound c & pure+saveUTerm (USkolem c) = USkolem c & pure+saveUTerm (UToVar v) = saveVar v <&> UToVar+saveUTerm (UTerm u) = uBody saveBody u <&> UTerm+saveUTerm UInstantiated{} = error "converting bindings during instantiation"+saveUTerm UResolving{} = error "converting bindings after resolution"+saveUTerm UResolved{} = error "converting bindings after resolution"+saveUTerm UConverted{} = error "converting variable again"++saveVar ::+    forall m t typeVars.+    (Unify m t, Recursively (HNodeLens typeVars) t) =>+    UVarOf m # t ->+    StateT (typeVars # Binding, [m ()]) m (UVar # t)+saveVar v =+    withDict (recursively (Proxy @(HNodeLens typeVars t))) $+    lookupVar binding v & lift+    >>=+    \case+    UConverted i -> pure (UVar i)+    srcBody ->+        do+            pb <- Lens.use (Lens._1 . hNodeLens)+            let r = pb ^. _Binding & length+            UConverted r & bindVar binding v & lift+            Lens._2 %= (<> [bindVar binding v srcBody])+            dstBody <- saveUTerm srcBody+            Lens._1 . hNodeLens .= (pb & _Binding %~ (Lens.|> dstBody))+            UVar r & pure++saveBody ::+    forall m typeVars t.+    (Unify m t, Recursively (HNodeLens typeVars) t) =>+    t # UVarOf m ->+    StateT (typeVars # Binding, [m ()]) m (t # UVar)+saveBody =+    withDict (recurse (Proxy @(Unify m t))) $+    withDict (recursively (Proxy @(HNodeLens typeVars t))) $+    htraverse+    ( Proxy @(Unify m) #*# Proxy @(Recursively (HNodeLens typeVars))+        #> saveVar+    )++-- | Serialize the state of unification for+-- the unification variables in a given value,+-- and transform the value's unification variables+-- to their serialized identifiers.+save ::+    (Unify m t, Recursively (HNodeLens typeVars) t) =>+    t # UVarOf m ->+    StateT (typeVars # Binding) m (t # UVar)+save collection =+    StateT $+    \dstState ->+    do+        (r, (finalState, recover)) <- runStateT (saveBody collection) (dstState, [])+        (r, finalState) <$ sequence_ recover
+ src/Hyper/Unify/Constraints.hs view
@@ -0,0 +1,55 @@+-- | A class for constraints for unification variables++{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}++module Hyper.Unify.Constraints+    ( TypeConstraints(..)+    , HasTypeConstraints(..)+    , WithConstraint(..), wcConstraint, wcBody+    ) where++import Algebra.PartialOrd (PartialOrd(..))+import Data.Kind (Type)+import Hyper (HyperType, GetHyperType, type (#))++import Hyper.Internal.Prelude++-- | A class for constraints for unification variables.+class (PartialOrd c, Monoid c) => TypeConstraints c where+    -- | Remove scope constraints.+    --+    -- When generalizing unification variables into universally+    -- quantified variables, and then into fresh unification variables+    -- upon instantiation, some constraints need to be carried over,+    -- and the "scope" constraints need to be erased.+    generalizeConstraints :: c -> c++    -- | Remove all constraints other than the scope constraints+    --+    -- Useful for comparing constraints to the current scope constraints+    toScopeConstraints :: c -> c++-- | A class for terms that have constraints.+--+-- A dependency of `Hyper.Class.Unify.Unify`+class+    TypeConstraints (TypeConstraintsOf ast) =>+    HasTypeConstraints (ast :: HyperType) where++    type TypeConstraintsOf (ast :: HyperType) :: Type++    -- | Verify constraints on the ast and apply the given child+    -- verifier on children+    verifyConstraints ::+        TypeConstraintsOf ast ->+        ast # h ->+        Maybe (ast # WithConstraint h)++-- | A 'HyperType' to represent a term alongside a constraint.+--+-- Used for 'verifyConstraints'.+data WithConstraint h ast = WithConstraint+    { _wcConstraint :: TypeConstraintsOf (GetHyperType ast)+    , _wcBody :: h ast+    }+makeLenses ''WithConstraint
+ src/Hyper/Unify/Error.hs view
@@ -0,0 +1,53 @@+-- | A type for unification errors++{-# LANGUAGE TemplateHaskell, UndecidableInstances #-}++module Hyper.Unify.Error+    ( UnifyError(..)+    , _SkolemUnified, _SkolemEscape, _ConstraintsViolation+    , _Occurs, _Mismatch+    ) where++import           Generics.Constraints (Constraints)+import           Hyper+import           Hyper.Unify.Constraints (TypeConstraintsOf)+import           Text.PrettyPrint ((<+>))+import qualified Text.PrettyPrint as Pretty+import           Text.PrettyPrint.HughesPJClass (Pretty(..), maybeParens)++import           Hyper.Internal.Prelude++-- | An error that occurred during unification+data UnifyError t h+    = SkolemUnified (h :# t) (h :# t)+      -- ^ A universally quantified variable was unified with a+      -- different type+    | SkolemEscape (h :# t)+      -- ^ A universally quantified variable escapes its scope+    | ConstraintsViolation (t h) (TypeConstraintsOf t)+      -- ^ A term violates constraints that should apply to it+    | Occurs (t h) (t h)+      -- ^ Infinite type encountered. A type occurs within itself+    | Mismatch (t h) (t h)+      -- ^ Unification between two mismatching type structures+    deriving Generic++makePrisms ''UnifyError+makeCommonInstances [''UnifyError]+makeHTraversableAndBases ''UnifyError++instance Constraints (UnifyError t h) Pretty => Pretty (UnifyError t h) where+    pPrintPrec lvl p =+        maybeParens haveParens . \case+        SkolemUnified x y        -> Pretty.text "SkolemUnified" <+> r x <+> r y+        SkolemEscape x           -> Pretty.text "SkolemEscape:" <+> r x+        Mismatch x y             -> Pretty.text "Mismatch" <+> r x <+> r y+        Occurs x y               -> r x <+> Pretty.text "occurs in itself, expands to:" <+> right y+        ConstraintsViolation x y -> Pretty.text "ConstraintsViolation" <+> r x <+> r y+        where+            haveParens = p > 10+            right+                | haveParens = pPrintPrec lvl 0+                | otherwise = pPrintPrec lvl p+            r :: Pretty a => a -> Pretty.Doc+            r = pPrintPrec lvl 11
+ src/Hyper/Unify/Generalize.hs view
@@ -0,0 +1,201 @@+-- | Generalization of type schemes++{-# LANGUAGE UndecidableInstances, TemplateHaskell, FlexibleContexts, FlexibleInstances #-}++module Hyper.Unify.Generalize+    ( generalize, instantiate++    , GTerm(..), _GMono, _GPoly, _GBody, W_GTerm(..)++    , instantiateWith, instantiateForAll++    , -- | Exports for @SPECIALIZE@ pragmas.+      instantiateH+    ) where++import           Algebra.PartialOrd (PartialOrd(..))+import qualified Control.Lens as Lens+import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.Writer (WriterT(..), tell)+import           Data.Monoid (All(..))+import           Hyper+import           Hyper.Class.Traversable+import           Hyper.Class.Unify+import           Hyper.Recurse+import           Hyper.Unify.Constraints+import           Hyper.Unify.New (newTerm)+import           Hyper.Unify.Term (UTerm(..), uBody)++import           Hyper.Internal.Prelude++-- | An efficient representation of a type scheme arising from+-- generalizing a unification term. Type subexpressions which are+-- completely monomoprhic are tagged as such, to avoid redundant+-- instantation and unification work+data GTerm v ast+    = GMono (v ast) -- ^ Completely monomoprhic term+    | GPoly (v ast)+        -- ^ Points to a quantified variable (instantiation will+        -- create fresh unification terms) (`Hyper.Unify.Term.USkolem`+        -- or `Hyper.Unify.Term.UResolved`)+    | GBody (ast :# GTerm v) -- ^ Term with some polymorphic parts+    deriving Generic++makePrisms ''GTerm+makeCommonInstances [''GTerm]+makeHTraversableAndBases ''GTerm++instance RNodes a => HNodes (HFlip GTerm a) where+    type HNodesConstraint (HFlip GTerm a) c = (c a, Recursive c)+    type HWitnessType (HFlip GTerm a) = HRecWitness a+    {-# INLINE hLiftConstraint #-}+    hLiftConstraint (HWitness HRecSelf) = const id+    hLiftConstraint (HWitness (HRecSub c n)) = hLiftConstraintH c n++hLiftConstraintH ::+    forall a c b n r.+    (RNodes a, HNodesConstraint (HFlip GTerm a) c) =>+    HWitness a b -> HRecWitness b n -> Proxy c -> (c n => r) -> r+hLiftConstraintH c n p f =+    withDict (recurse (Proxy @(RNodes a))) $+    withDict (recurse (Proxy @(c a))) $+    hLiftConstraint c (Proxy @RNodes)+    ( hLiftConstraint c p+        (hLiftConstraint (HWitness @(HFlip GTerm _) n) p f)+    )++instance Recursively HFunctor ast => HFunctor (HFlip GTerm ast) where+    {-# INLINE hmap #-}+    hmap f =+        _HFlip %~+        \case+        GMono x -> f (HWitness HRecSelf) x & GMono+        GPoly x -> f (HWitness HRecSelf) x & GPoly+        GBody x ->+            withDict (recursively (Proxy @(HFunctor ast))) $+            hmap+            ( \cw ->+                hLiftConstraint cw (Proxy @(Recursively HFunctor)) $+                hflipped %~+                hmap (f . (\(HWitness nw) -> HWitness (HRecSub cw nw)))+            ) x+            & GBody++instance Recursively HFoldable ast => HFoldable (HFlip GTerm ast) where+    {-# INLINE hfoldMap #-}+    hfoldMap f =+        \case+        GMono x -> f (HWitness HRecSelf) x+        GPoly x -> f (HWitness HRecSelf) x+        GBody x ->+            withDict (recursively (Proxy @(HFoldable ast))) $+            hfoldMap+            ( \cw ->+                hLiftConstraint cw (Proxy @(Recursively HFoldable)) $+                hfoldMap (f . (\(HWitness nw) -> HWitness (HRecSub cw nw)))+                . (_HFlip #)+            ) x+        . (^. _HFlip)++instance RTraversable ast => HTraversable (HFlip GTerm ast) where+    {-# INLINE hsequence #-}+    hsequence =+        \case+        GMono x -> runContainedH x <&> GMono+        GPoly x -> runContainedH x <&> GPoly+        GBody x ->+            withDict (recurse (Proxy @(RTraversable ast))) $+            -- HTraversable will be required when not implied by Recursively+            htraverse (Proxy @RTraversable #> hflipped hsequence) x+            <&> GBody+        & _HFlip++-- | Generalize a unification term pointed by the given variable to a `GTerm`.+-- Unification variables that are scoped within the term+-- become universally quantified skolems.+generalize ::+    forall m t.+    UnifyGen m t =>+    UVarOf m # t -> m (GTerm (UVarOf m) # t)+generalize v0 =+    do+        (v1, u) <- semiPruneLookup v0+        c <- scopeConstraints (Proxy @t)+        case u of+            UUnbound l | toScopeConstraints l `leq` c ->+                GPoly v1 <$+                -- We set the variable to a skolem,+                -- so additional unifications after generalization+                -- (for example hole resumptions where supported)+                -- cannot unify it with anything.+                bindVar binding v1 (USkolem (generalizeConstraints l))+            USkolem l | toScopeConstraints l `leq` c -> pure (GPoly v1)+            UTerm t ->+                withDict (unifyGenRecursive (Proxy @m) (Proxy @t)) $+                do+                    bindVar binding v1 (UResolving t)+                    r <- htraverse (Proxy @(UnifyGen m) #> generalize) (t ^. uBody)+                    r <$ bindVar binding v1 (UTerm t)+                <&>+                \b ->+                if hfoldMap (Proxy @(UnifyGen m) #> All . Lens.has _GMono) b ^. Lens._Wrapped+                then GMono v1+                else GBody b+            UResolving t -> GMono v1 <$ occursError v1 t+            _ -> pure (GMono v1)++{-# INLINE instantiateForAll #-}+instantiateForAll ::+    forall m t. UnifyGen m t =>+    (TypeConstraintsOf t -> UTerm (UVarOf m) # t) ->+    UVarOf m # t ->+    WriterT [m ()] m (UVarOf m # t)+instantiateForAll cons x =+    lookupVar binding x & lift+    >>=+    \case+    USkolem l ->+        do+            tell [bindVar binding x (USkolem l)]+            r <- scopeConstraints (Proxy @t) <&> (<> l) >>= newVar binding . cons & lift+            UInstantiated r & bindVar binding x & lift+            pure r+    UInstantiated v -> pure v+    _ -> error "unexpected state at instantiate's forall"++-- TODO: Better name?+{-# INLINE instantiateH #-}+instantiateH ::+    forall m t.+    UnifyGen m t =>+    (forall n. TypeConstraintsOf n -> UTerm (UVarOf m) # n) ->+    GTerm (UVarOf m) # t ->+    WriterT [m ()] m (UVarOf m # t)+instantiateH _ (GMono x) = pure x+instantiateH cons (GPoly x) = instantiateForAll cons x+instantiateH cons (GBody x) =+    withDict (unifyGenRecursive (Proxy @m) (Proxy @t)) $+    htraverse (Proxy @(UnifyGen m) #> instantiateH cons) x >>= lift . newTerm++{-# INLINE instantiateWith #-}+instantiateWith ::+    forall m t a.+    UnifyGen m t =>+    m a ->+    (forall n. TypeConstraintsOf n -> UTerm (UVarOf m) # n) ->+    GTerm (UVarOf m) # t ->+    m (UVarOf m # t, a)+instantiateWith action cons g =+    do+        (r, recover) <-+            instantiateH cons g+            & runWriterT+        action <* sequence_ recover <&> (r, )++-- | Instantiate a generalized type with fresh unification variables+-- for the quantified variables+{-# INLINE instantiate #-}+instantiate ::+    UnifyGen m t =>+    GTerm (UVarOf m) # t -> m (UVarOf m # t)+instantiate g = instantiateWith (pure ()) UUnbound g <&> (^. Lens._1)
+ src/Hyper/Unify/New.hs view
@@ -0,0 +1,27 @@+-- | Generate new unification variables+{-# LANGUAGE FlexibleContexts #-}+module Hyper.Unify.New+    ( newUnbound, newTerm, unfreeze+    ) where++import Hyper+import Hyper.Class.Unify (Unify(..), UnifyGen(..), UVarOf, BindingDict(..))+import Hyper.Recurse+import Hyper.Unify.Term (UTerm(..), UTermBody(..))++import Prelude.Compat++-- | Create a new unbound unification variable in the current scope+{-# INLINE newUnbound #-}+newUnbound :: forall m t. UnifyGen m t => m (UVarOf m # t)+newUnbound = scopeConstraints (Proxy @t) >>= newVar binding . UUnbound++-- | Create a new unification term with a given body+{-# INLINE newTerm #-}+newTerm :: forall m t. UnifyGen m t => t # UVarOf m -> m (UVarOf m # t)+newTerm x = scopeConstraints (Proxy @t) >>= newVar binding . UTerm . (`UTermBody` x)++-- | Embed a pure term as a unification term+{-# INLINE unfreeze #-}+unfreeze :: forall m t. UnifyGen m t => Pure # t -> m (UVarOf m # t)+unfreeze = wrapM (Proxy @(UnifyGen m) #>> newTerm)
+ src/Hyper/Unify/Occurs.hs view
@@ -0,0 +1,45 @@+-- | Occurs check (check whether unification terms recursively contains themselves)++module Hyper.Unify.Occurs+    ( occursCheck+    ) where++import Control.Monad (unless, when)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.State (execStateT, get, put)+import Hyper+import Hyper.Class.Unify (Unify(..), UVarOf, BindingDict(..), semiPruneLookup, occursError)+import Hyper.Unify.Term (UTerm(..), uBody)++import Hyper.Internal.Prelude++-- | Occurs check+{-# INLINE occursCheck #-}+occursCheck ::+    forall m t.+    Unify m t =>+    UVarOf m # t -> m ()+occursCheck v0 =+    semiPruneLookup v0+    >>=+    \(v1, x) ->+    case x of+    UResolving t -> occursError v1 t+    UResolved{} -> pure ()+    UUnbound{} -> pure ()+    USkolem{} -> pure ()+    UTerm b ->+        withDict (unifyRecursive (Proxy @m) (Proxy @t)) $+        htraverse_+        ( Proxy @(Unify m) #>+            \c ->+            do+                get >>= lift . (`unless` bindVar binding v1 (UResolving b))+                put True+                occursCheck c & lift+        ) (b ^. uBody)+        & (`execStateT` False)+        >>= (`when` bindVar binding v1 (UTerm b))+    UToVar{} -> error "lookup not expected to result in var (in occursCheck)"+    UConverted{} -> error "conversion state not expected in occursCheck"+    UInstantiated{} -> error "occursCheck during instantiation"
+ src/Hyper/Unify/QuantifiedVar.hs view
@@ -0,0 +1,30 @@+-- | A class for types that have quantified variables.++{-# LANGUAGE UndecidableInstances, FlexibleInstances, FlexibleContexts #-}++module Hyper.Unify.QuantifiedVar+    ( HasQuantifiedVar(..)+    , MonadQuantify(..)+    , OrdQVar+    ) where++import Control.Lens (Prism')+import Hyper.Type (HyperType)++import Prelude.Compat++-- | Class for types which have quantified variables+class HasQuantifiedVar (t :: HyperType) where+    -- | The type of quantified variable identifiers+    type QVar t+    -- | A `Prism'` from a type to its quantified variable term+    quantifiedVar :: Prism' (t f) (QVar t)++-- | A constraint synonym that represents that+-- the quantified variable of a type has an 'Ord' instance+class    (HasQuantifiedVar t, Ord (QVar t)) => OrdQVar t+instance (HasQuantifiedVar t, Ord (QVar t)) => OrdQVar t++-- | A monad where new quantified variables can be generated+class MonadQuantify typeConstraints q m where+    newQuantifiedVariable :: typeConstraints -> m q
+ src/Hyper/Unify/Term.hs view
@@ -0,0 +1,53 @@+-- | Unification terms.+--+-- These represent the known state of a unification variable.++{-# LANGUAGE TemplateHaskell, UndecidableInstances #-}++module Hyper.Unify.Term+    ( UTerm(..)+        , _UUnbound, _USkolem, _UToVar, _UTerm, _UInstantiated+        , _UResolving, _UResolved, _UConverted+    , UTermBody(..), uBody, uConstraints+    ) where++import Hyper+import Hyper.Unify.Constraints (TypeConstraintsOf)++import Hyper.Internal.Prelude++-- | A unification term with a known body+data UTermBody v ast = UTermBody+    { _uConstraints :: TypeConstraintsOf (GetHyperType ast)+    , _uBody :: ast :# v+    } deriving Generic++-- | A unification term pointed by a unification variable+data UTerm v ast+    = UUnbound (TypeConstraintsOf (GetHyperType ast))+      -- ^ Unbound variable with at least the given constraints+    | USkolem (TypeConstraintsOf (GetHyperType ast))+      -- ^ A variable bound by a rigid quantified variable with+      -- *exactly* the given constraints+    | UToVar (v ast)+      -- ^ Unified with another variable (union-find)+    | UTerm (UTermBody v ast)+      -- ^ Known type term with unification variables as children+    | UInstantiated (v ast)+      -- ^ Temporary state during instantiation indicating which fresh+      -- unification variable a skolem is mapped to+    | UResolving (UTermBody v ast)+      -- ^ Temporary state while unification term is being traversed,+      -- if it occurs inside itself (detected via state still being+      -- UResolving), then the type is an infinite type+    | UResolved (Pure ast)+      -- ^ Final resolved state. `Hyper.Unify.applyBindings` resolved to+      -- this expression (allowing caching/sharing)+    | UConverted Int+      -- ^ Temporary state used in "Hyper.Unify.Binding.ST.Save" while+      -- converting to a pure binding+    deriving Generic++makePrisms ''UTerm+makeLenses ''UTermBody+makeCommonInstances [''UTerm, ''UTermBody]
+ test/Benchmark.hs view
@@ -0,0 +1,35 @@+import Control.Exception (evaluate)+import Control.Lens.Operators+import Criterion (Benchmarkable, whnfIO)+import Criterion.Main (bench, defaultMain)+import Hyper+import Hyper.Unify+import Hyper.Unify.New (unfreeze)+import LangB+import Text.PrettyPrint.HughesPJClass (prettyShow)+import TypeLang++fields :: [String]+fields = [ 'a' : show i | i <- [0 :: Int .. 100] ]++record :: [String] -> Pure # Typ+record = (^. hPlain) . TRecP . foldr (\k -> RExtendP (Name k) TIntP) REmptyP++recordFwd :: Pure # Typ+recordFwd = record fields++recordBwd :: Pure # Typ+recordBwd = record (reverse fields)++unifyLargeRows :: Benchmarkable+unifyLargeRows =+    do+        r1 <- unfreeze recordFwd+        r2 <- unfreeze recordBwd+        unify r1 r2+        & execPureInferB+        & either (fail . prettyShow) evaluate+        & whnfIO++main :: IO ()+main = defaultMain [bench "Unify large rows" unifyLargeRows]
+ test/Hyper/Class/Infer/Infer1.hs view
@@ -0,0 +1,23 @@+-- | 'Infer' for indexed AST types (such as 'Hyper.Type.AST.Scope.Scope')++module Hyper.Class.Infer.Infer1+    ( HasTypeOf1(..), HasInferOf1(..), Infer1(..)+    ) where++import Data.Constraint (Constraint, Dict, (:-))+import Data.Kind (Type)+import Data.Proxy (Proxy(..))+import Hyper.Infer+import Hyper.Type (HyperType)++class HasTypeOf1 t where+    type TypeOf1 t :: HyperType+    typeAst :: Proxy (t h) -> Dict (TypeOf (t h) ~ TypeOf1 t)++class HasInferOf1 t where+    type InferOf1 t :: HyperType+    type InferOf1IndexConstraint t :: Type -> Constraint+    hasInferOf1 :: Proxy (t h) -> Dict (InferOf (t h) ~ InferOf1 t)++class HasInferOf1 t => Infer1 m t where+    inferMonad :: InferOf1IndexConstraint t i :- Infer m (t i)
+ test/Hyper/Type/AST/NamelessScope.hs view
@@ -0,0 +1,128 @@+-- | A 'HyperType' based implementation of "locally-nameless" terms,+-- inspired by the [bound](http://hackage.haskell.org/package/bound) library+-- and the technique from Bird & Paterson's+-- ["de Bruijn notation as a nested datatype"](https://www.semanticscholar.org/paper/De-Bruijn-Notation-as-a-Nested-Datatype-Bird-Paterson/254b3b01651c5e325d9b3cd15c106fbec40e53ea)++{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances, TemplateHaskell, EmptyCase, EmptyDataDeriving #-}++module Hyper.Type.AST.NamelessScope+    ( Scope(..), _Scope, W_Scope(..)+    , ScopeVar(..), _ScopeVar+    , EmptyScope+    , DeBruijnIndex(..)+    , ScopeTypes(..), _ScopeTypes, W_ScopeTypes(..)+    , HasScopeTypes(..)+    ) where++import           Control.Lens (Lens', Prism')+import           Control.Lens.Operators+import qualified Control.Lens as Lens+import           Control.Monad.Reader (MonadReader)+import           Data.Constraint ((:-), (\\))+import           Data.Kind (Type)+import           Data.Sequence (Seq)+import qualified Data.Sequence as Sequence+import           Hyper+import           Hyper.Class.Infer.Infer1+import           Hyper.Infer+import           Hyper.Type.AST.FuncType+import           Hyper.Unify (UnifyGen, UVarOf)+import           Hyper.Unify.New (newUnbound)++data EmptyScope deriving Show++newtype Scope expr a h = Scope (h :# expr (Maybe a))+Lens.makePrisms ''Scope++newtype ScopeVar (expr :: Type -> HyperType) a (h :: AHyperType) = ScopeVar a+Lens.makePrisms ''ScopeVar++makeZipMatch ''Scope+makeHTraversableApplyAndBases ''Scope+makeZipMatch ''ScopeVar+makeHTraversableApplyAndBases ''ScopeVar++class DeBruijnIndex a where+    deBruijnIndex :: Prism' Int a++instance DeBruijnIndex EmptyScope where+    deBruijnIndex = Lens.prism (\case{}) Left++instance DeBruijnIndex a => DeBruijnIndex (Maybe a) where+    deBruijnIndex =+        Lens.prism' toInt fromInt+        where+            toInt Nothing = 0+            toInt (Just x) = 1 + deBruijnIndex # x+            fromInt x+                | x == 0 = Just Nothing+                | otherwise = (x - 1) ^? deBruijnIndex <&> Just++newtype ScopeTypes t v = ScopeTypes (Seq (v :# t))+    deriving newtype (Semigroup, Monoid)++Lens.makePrisms ''ScopeTypes+makeHTraversableApplyAndBases ''ScopeTypes++-- TODO: Replace this class with ones from Infer+class HasScopeTypes v t env where+    scopeTypes :: Lens' env (ScopeTypes t # v)++instance HasScopeTypes v t (ScopeTypes t # v) where+    scopeTypes = id++type instance InferOf (Scope t h) = FuncType (TypeOf (t h))+type instance InferOf (ScopeVar t h) = ANode (TypeOf (t h))++instance HasTypeOf1 t => HasInferOf1 (Scope t) where+    type InferOf1 (Scope t) = FuncType (TypeOf1 t)+    type InferOf1IndexConstraint (Scope t) = DeBruijnIndex+    hasInferOf1 p =+        withDict (typeAst (p0 p)) Dict+        where+            p0 :: Proxy (Scope t h) -> Proxy (t h)+            p0 _ = Proxy++instance+    ( Infer1 m t+    , HasInferOf1 t+    , InferOf1IndexConstraint t ~ DeBruijnIndex+    , DeBruijnIndex h+    , UnifyGen m (TypeOf (t h))+    , MonadReader env m+    , HasScopeTypes (UVarOf m) (TypeOf (t h)) env+    , HasInferredType (t h)+    ) =>+    Infer m (Scope t h) where++    inferBody (Scope x) =+        withDict (hasInferOf1 (Proxy @(t h))) $+        withDict (hasInferOf1 (Proxy @(t (Maybe h)))) $+        do+            varType <- newUnbound+            inferChild x+                & Lens.locally (scopeTypes . _ScopeTypes) (varType Sequence.<|)+                <&>+                \(InferredChild xI xR) ->+                ( Scope xI+                , FuncType varType (xR ^# inferredType (Proxy @(t h)))+                )+        \\ (inferMonad :: DeBruijnIndex (Maybe h) :- Infer m (t (Maybe h)))++    inferContext _ _ =+        Dict \\ inferMonad @m @t @(Maybe h)++instance+    ( MonadReader env m+    , HasScopeTypes (UVarOf m) (TypeOf (t h)) env+    , DeBruijnIndex h+    , UnifyGen m (TypeOf (t h))+    ) =>+    Infer m (ScopeVar t h) where++    inferBody (ScopeVar v) =+        Lens.view (scopeTypes . _ScopeTypes)+        <&> (^?! Lens.ix (deBruijnIndex # v))+        <&> MkANode+        <&> (ScopeVar v, )
+ test/Hyper/Type/AST/NamelessScope/InvDeBruijn.hs view
@@ -0,0 +1,34 @@+module Hyper.Type.AST.NamelessScope.InvDeBruijn+    ( InvDeBruijnIndex(..), inverseDeBruijnIndex, scope, scopeVar+    ) where++import Control.Lens (Prism', iso)+import Control.Lens.Operators+import Data.Proxy (Proxy(..))+import Hyper.Type (type (#))+import Hyper.Type.AST.NamelessScope (DeBruijnIndex(..), EmptyScope, Scope(..), ScopeVar(..))++class DeBruijnIndex a => InvDeBruijnIndex a where+    deBruijnIndexMax :: Proxy a -> Int++instance InvDeBruijnIndex EmptyScope where+    deBruijnIndexMax _ = -1++instance InvDeBruijnIndex a => InvDeBruijnIndex (Maybe a) where+    deBruijnIndexMax _ = 1 + deBruijnIndexMax (Proxy @a)++inverseDeBruijnIndex :: forall a. InvDeBruijnIndex a => Prism' Int a+inverseDeBruijnIndex =+    iso (l -) (l -) . deBruijnIndex+    where+        l = deBruijnIndexMax (Proxy @a)++scope ::+    forall expr a f.+    InvDeBruijnIndex a =>+    (Int -> f # expr (Maybe a)) ->+    Scope expr a # f+scope f = Scope (f (inverseDeBruijnIndex # (Nothing :: Maybe a)))++scopeVar :: InvDeBruijnIndex a => Int -> ScopeVar expr a f+scopeVar x = ScopeVar (x ^?! inverseDeBruijnIndex)
+ test/LangA.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE UndecidableInstances, TemplateHaskell, FlexibleInstances, FlexibleContexts #-}++-- | A test language with locally-nameless variable scoping and type signatures with for-alls++module LangA where++import           TypeLang++import           Control.Applicative+import qualified Control.Lens as Lens+import           Control.Lens.Operators+import           Control.Monad.Except+import           Control.Monad.RWS+import           Control.Monad.Reader+import           Control.Monad.ST+import           Control.Monad.ST.Class (MonadST(..))+import           Data.Constraint+import           Data.STRef+import           Hyper+import           Hyper.Class.Infer.Infer1+import           Hyper.Infer+import           Hyper.Type.AST.App+import           Hyper.Type.AST.NamelessScope+import           Hyper.Type.AST.NamelessScope.InvDeBruijn+import           Hyper.Type.AST.Scheme+import           Hyper.Type.AST.TypeSig+import           Hyper.Unify+import           Hyper.Unify.Binding+import           Hyper.Unify.Binding.ST+import           Hyper.Unify.New+import           Hyper.Unify.QuantifiedVar+import           Text.PrettyPrint ((<+>))+import qualified Text.PrettyPrint as Pretty+import           Text.PrettyPrint.HughesPJClass (Pretty(..), maybeParens)++import           Prelude++data LangA v h+    = ALam (Scope LangA v h)+    | AVar (ScopeVar LangA v h)+    | AApp (App (LangA v) h)+    | ATypeSig (TypeSig Types (LangA v) h)+    | ALit Int++makeHTraversableAndBases ''LangA+makeHasHPlain [''LangA]++instance RNodes (LangA v)+instance Recursively HFunctor (LangA h)+instance Recursively HFoldable (LangA h)+instance RTraversable (LangA h)++type instance InferOf (LangA h) = ANode Typ++instance Recursively (InferOfConstraint HFunctor) (LangA h)+instance Recursively (InferOfConstraint HFoldable) (LangA h)+instance RTraversableInferOf (LangA h)++instance HasInferredType (LangA h) where+    type TypeOf (LangA h) = Typ+    inferredType _ = _ANode++instance InvDeBruijnIndex v => Pretty (LangA v ('AHyperType Pure)) where+    pPrintPrec lvl p (ALam (Scope expr)) =+        Pretty.hcat+        [ Pretty.text "λ("+        , pPrint (1 + deBruijnIndexMax (Proxy @v))+        , Pretty.text ")."+        ] <+> pPrintPrec lvl 0 expr+        & maybeParens (p > 0)+    pPrintPrec _ _ (AVar (ScopeVar v)) =+        Pretty.text "#" <> pPrint (inverseDeBruijnIndex # v)+    pPrintPrec lvl p (AApp (App f x)) =+        pPrintPrec lvl p f <+> pPrintPrec lvl p x+    pPrintPrec lvl p (ATypeSig typeSig) = pPrintPrec lvl p typeSig+    pPrintPrec _ _ (ALit i) = pPrint i++instance HasTypeOf1 LangA where+    type TypeOf1 LangA = Typ+    typeAst _ = Dict++instance HasInferOf1 LangA where+    type InferOf1 LangA = ANode Typ+    type InferOf1IndexConstraint LangA = DeBruijnIndex+    hasInferOf1 _ = Dict++type TermInfer1Deps env m =+    ( MonadScopeLevel m+    , MonadReader env m+    , HasScopeTypes (UVarOf m) Typ env+    , MonadInstantiate m Typ, MonadInstantiate m Row+    )++instance TermInfer1Deps env m => Infer1 m LangA where+    inferMonad = Sub Dict++instance (DeBruijnIndex h, TermInfer1Deps env m) => Infer m (LangA h) where+    inferBody (ALit x) = newTerm TInt <&> MkANode <&> (ALit x, )+    inferBody (AVar x) = inferBody x <&> Lens._1 %~ AVar+    inferBody (ALam x) =+        inferBody x+        >>= \(b, t) -> TFun t & newTerm <&> (ALam b, ) . MkANode+    inferBody (AApp x) = inferBody x <&> Lens._1 %~ AApp+    inferBody (ATypeSig x) = inferBody x <&> Lens._1 %~ ATypeSig++-- Monads for inferring `LangA`:++data LangAInferEnv v = LangAInferEnv+    { _iaScopeTypes :: ScopeTypes Typ # v+    , _iaScopeLevel :: ScopeLevel+    , _iaInstantiations :: Types # QVarInstances v+    }+Lens.makeLenses ''LangAInferEnv++emptyLangAInferEnv :: LangAInferEnv v+emptyLangAInferEnv =+    LangAInferEnv mempty (ScopeLevel 0)+    (hpure (Proxy @OrdQVar #> QVarInstances mempty))++instance HasScopeTypes v Typ (LangAInferEnv v) where scopeTypes = iaScopeTypes++newtype PureInferA a =+    PureInferA+    ( RWST (LangAInferEnv UVar) () PureInferState+        (Either (TypeError # Pure)) a+    )+    deriving newtype+    ( Functor, Applicative, Monad+    , MonadError (TypeError # Pure)+    , MonadReader (LangAInferEnv UVar)+    , MonadState PureInferState+    )++execPureInferA :: PureInferA a -> Either (TypeError # Pure) a+execPureInferA (PureInferA act) =+    runRWST act emptyLangAInferEnv emptyPureInferState+    <&> (^. Lens._1)++type instance UVarOf PureInferA = UVar++instance MonadScopeLevel PureInferA where+    localLevel = local (iaScopeLevel . _ScopeLevel +~ 1)++instance UnifyGen PureInferA Typ where+    scopeConstraints _ = Lens.view iaScopeLevel++instance UnifyGen PureInferA Row where+    scopeConstraints _ = Lens.view iaScopeLevel <&> RowConstraints mempty++instance MonadQuantify ScopeLevel Name PureInferA where+    newQuantifiedVariable _ =+        pisFreshQVars . tTyp . Lens._Wrapped <<+= 1 <&> Name . ('t':) . show++instance MonadQuantify RConstraints Name PureInferA where+    newQuantifiedVariable _ =+        pisFreshQVars . tRow . Lens._Wrapped <<+= 1 <&> Name . ('r':) . show++instance Unify PureInferA Typ where+    binding = bindingDict (pisBindings . tTyp)++instance Unify PureInferA Row where+    binding = bindingDict (pisBindings . tRow)+    structureMismatch = rStructureMismatch++instance MonadInstantiate PureInferA Typ where+    localInstantiations (QVarInstances x) =+        local (iaInstantiations . tTyp . _QVarInstances <>~ x)+    lookupQVar x =+        Lens.view (iaInstantiations . tTyp . _QVarInstances . Lens.at x)+        >>= maybe (throwError (QVarNotInScope x)) pure++instance MonadInstantiate PureInferA Row where+    localInstantiations (QVarInstances x) =+        local (iaInstantiations . tRow . _QVarInstances <>~ x)+    lookupQVar x =+        Lens.view (iaInstantiations . tRow . _QVarInstances . Lens.at x)+        >>= maybe (throwError (QVarNotInScope x)) pure++newtype STInferA s a =+    STInferA+    ( ReaderT (LangAInferEnv (STUVar s), STNameGen s)+        (ExceptT (TypeError # Pure) (ST s)) a+    )+    deriving newtype+    ( Functor, Applicative, Monad, MonadST+    , MonadError (TypeError # Pure)+    , MonadReader (LangAInferEnv (STUVar s), STNameGen s)+    )++execSTInferA :: STInferA s a -> ST s (Either (TypeError # Pure) a)+execSTInferA (STInferA act) =+    do+        qvarGen <- Types <$> (newSTRef 0 <&> Const) <*> (newSTRef 0 <&> Const)+        runReaderT act (emptyLangAInferEnv, qvarGen) & runExceptT++type instance UVarOf (STInferA s) = STUVar s++instance MonadScopeLevel (STInferA s) where+    localLevel = local (Lens._1 . iaScopeLevel . _ScopeLevel +~ 1)++instance UnifyGen (STInferA s) Typ where+    scopeConstraints _ = Lens.view (Lens._1 . iaScopeLevel)++instance UnifyGen (STInferA s) Row where+    scopeConstraints _ = Lens.view (Lens._1 . iaScopeLevel) <&> RowConstraints mempty++instance MonadQuantify ScopeLevel Name (STInferA s) where+    newQuantifiedVariable _ = newStQuantified (Lens._2 . tTyp) <&> Name . ('t':) . show++instance MonadQuantify RConstraints Name (STInferA s) where+    newQuantifiedVariable _ = newStQuantified (Lens._2 . tRow) <&> Name . ('r':) . show++instance Unify (STInferA s) Typ where+    binding = stBinding++instance Unify (STInferA s) Row where+    binding = stBinding+    structureMismatch = rStructureMismatch++instance MonadInstantiate (STInferA s) Typ where+    localInstantiations (QVarInstances x) =+        local (Lens._1 . iaInstantiations . tTyp . _QVarInstances <>~ x)+    lookupQVar x =+        Lens.view (Lens._1 . iaInstantiations . tTyp . _QVarInstances . Lens.at x)+        >>= maybe (throwError (QVarNotInScope x)) pure++instance MonadInstantiate (STInferA s) Row where+    localInstantiations (QVarInstances x) =+        local (Lens._1 . iaInstantiations . tRow . _QVarInstances <>~ x)+    lookupQVar x =+        Lens.view (Lens._1 . iaInstantiations . tRow . _QVarInstances . Lens.at x)+        >>= maybe (throwError (QVarNotInScope x)) pure++instance HasScheme Types PureInferA Typ+instance HasScheme Types PureInferA Row+instance HasScheme Types (STInferA s) Typ+instance HasScheme Types (STInferA s) Row
+ test/LangB.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}++module LangB where++import           TypeLang++import           Control.Applicative+import qualified Control.Lens as Lens+import           Control.Lens.Operators+import           Control.Monad.Except+import           Control.Monad.RWS+import           Control.Monad.Reader+import           Control.Monad.ST+import           Control.Monad.ST.Class (MonadST(..))+import           Data.Map (Map)+import           Data.STRef+import           Data.String (IsString(..))+import           Hyper+import           Hyper.Infer+import           Hyper.Type.AST.App+import           Hyper.Type.AST.Lam+import           Hyper.Type.AST.Let+import           Hyper.Type.AST.Nominal+import           Hyper.Type.AST.Row+import           Hyper.Type.AST.Scheme+import           Hyper.Type.AST.Var+import           Hyper.Unify+import           Hyper.Unify.Binding+import           Hyper.Unify.Binding.ST+import           Hyper.Unify.Generalize+import           Hyper.Unify.New+import           Hyper.Unify.QuantifiedVar+import           Hyper.Unify.Term+import           Generics.Constraints (makeDerivings)+import qualified Text.PrettyPrint as P+import           Text.PrettyPrint.HughesPJClass (Pretty(..), maybeParens)++import           Prelude++data LangB h+    = BLit Int+    | BApp (App LangB h)+    | BVar (Var Name LangB h)+    | BLam (Lam Name LangB h)+    | BLet (Let Name LangB h)+    | BRecEmpty+    | BRecExtend (RowExtend Name LangB LangB h)+    | BGetField (h :# LangB) Name+    | BToNom (ToNom Name LangB h)+    deriving Generic++makeHTraversableAndBases ''LangB+makeHMorph ''LangB+instance c LangB => Recursively c LangB+instance RNodes LangB+instance RTraversable LangB++type instance InferOf LangB = ANode Typ+type instance ScopeOf LangB = ScopeTypes++instance HasInferredType LangB where+    type TypeOf LangB = Typ+    inferredType _ = _ANode++instance Pretty (LangB # Pure) where+    pPrintPrec _ _ (BLit i) = pPrint i+    pPrintPrec _ _ BRecEmpty = P.text "{}"+    pPrintPrec lvl p (BRecExtend (RowExtend h v r)) =+        pPrintPrec lvl 20 h P.<+>+        P.text "=" P.<+>+        (pPrintPrec lvl 2 v <> P.text ",") P.<+>+        pPrintPrec lvl 1 r+        & maybeParens (p > 1)+    pPrintPrec lvl p (BApp x) = pPrintPrec lvl p x+    pPrintPrec lvl p (BVar x) = pPrintPrec lvl p x+    pPrintPrec lvl p (BLam x) = pPrintPrec lvl p x+    pPrintPrec lvl p (BLet x) = pPrintPrec lvl p x+    pPrintPrec lvl p (BGetField w h) = pPrintPrec lvl p w <> P.text "." <> pPrint h+    pPrintPrec lvl p (BToNom n) = pPrintPrec lvl p n++instance VarType Name LangB where+    varType _ h (ScopeTypes t) =+        r t+        where+            r ::+                forall m. UnifyGen m Typ =>+                Map Name (HFlip GTerm Typ # UVarOf m) ->+                m (UVarOf m # Typ)+            r x =+                withDict (unifyRecursive (Proxy @m) (Proxy @Typ)) $+                x ^?! Lens.ix h . _HFlip & instantiate++instance+    ( MonadScopeLevel m+    , LocalScopeType Name (UVarOf m # Typ) m+    , LocalScopeType Name (GTerm (UVarOf m) # Typ) m+    , UnifyGen m Typ, UnifyGen m Row+    , HasScope m ScopeTypes+    , MonadNominals Name Typ m+    ) =>+    Infer m LangB where++    inferBody (BApp x) = inferBody x <&> Lens._1 %~ BApp+    inferBody (BVar x) = inferBody x <&> Lens._1 %~ BVar+    inferBody (BLam x) = inferBody x <&> Lens._1 %~ BLam+    inferBody (BLet x) = inferBody x <&> Lens._1 %~ BLet+    inferBody (BLit x) = newTerm TInt <&> (BLit x, ) . MkANode+    inferBody (BToNom x) =+        inferBody x+        >>= \(b, t) -> TNom t & newTerm <&> (BToNom b, ) . MkANode+    inferBody (BRecExtend (RowExtend h v r)) =+        do+            InferredChild vI vT <- inferChild v+            InferredChild rI rT <- inferChild r+            restR <-+                scopeConstraints (Proxy @Row)+                <&> rForbiddenFields . Lens.contains h .~ True+                >>= newVar binding . UUnbound+            _ <- TRec restR & newTerm >>= unify (rT ^. _ANode)+            RowExtend h (vT ^. _ANode) restR & RExtend & newTerm+                >>= newTerm . TRec+                <&> (BRecExtend (RowExtend h vI rI), ) . MkANode+    inferBody BRecEmpty =+        newTerm REmpty >>= newTerm . TRec <&> (BRecEmpty, ) . MkANode+    inferBody (BGetField w h) =+        do+            (rT, wR) <- rowElementInfer RExtend h+            InferredChild wI wT <- inferChild w+            (BGetField wI h, _ANode # rT) <$+                (newTerm (TRec wR) >>= unify (wT ^. _ANode))++instance RTraversableInferOf LangB++-- Monads for inferring `LangB`:++newtype ScopeTypes v = ScopeTypes (Map Name (HFlip GTerm Typ v))+    deriving stock Generic+    deriving newtype (Semigroup, Monoid)++makeDerivings [''Show] [''LangB, ''ScopeTypes]+makeHTraversableAndBases ''ScopeTypes++makeHasHPlain [''LangB]+instance IsString (HPlain LangB) where+    fromString = BVarP . fromString++Lens.makePrisms ''ScopeTypes++data InferScope v = InferScope+    { _varSchemes :: ScopeTypes # v+    , _scopeLevel :: ScopeLevel+    , _nominals :: Map Name (LoadedNominalDecl Typ # v)+    }+Lens.makeLenses ''InferScope++emptyInferScope :: InferScope v+emptyInferScope = InferScope mempty (ScopeLevel 0) mempty++newtype PureInferB a =+    PureInferB+    ( RWST (InferScope UVar) () PureInferState+        (Either (TypeError # Pure)) a+    )+    deriving newtype+    ( Functor, Applicative, Monad+    , MonadError (TypeError # Pure)+    , MonadReader (InferScope UVar)+    , MonadState PureInferState+    )++Lens.makePrisms ''PureInferB++execPureInferB :: PureInferB a -> Either (TypeError # Pure) a+execPureInferB act =+    runRWST (act ^. _PureInferB) emptyInferScope emptyPureInferState+    <&> (^. Lens._1)++type instance UVarOf PureInferB = UVar++instance MonadNominals Name Typ PureInferB where+    getNominalDecl name = Lens.view nominals <&> (^?! Lens.ix name)++instance HasScope PureInferB ScopeTypes where+    getScope = Lens.view varSchemes++instance LocalScopeType Name (UVar # Typ) PureInferB where+    localScopeType h v = local (varSchemes . _ScopeTypes . Lens.at h ?~ MkHFlip (GMono v))++instance LocalScopeType Name (GTerm UVar # Typ) PureInferB where+    localScopeType h v = local (varSchemes . _ScopeTypes . Lens.at h ?~ MkHFlip v)++instance MonadScopeLevel PureInferB where+    localLevel = local (scopeLevel . _ScopeLevel +~ 1)++instance UnifyGen PureInferB Typ where+    scopeConstraints _ = Lens.view scopeLevel++instance UnifyGen PureInferB Row where+    scopeConstraints _ = Lens.view scopeLevel <&> RowConstraints mempty++instance MonadQuantify ScopeLevel Name PureInferB where+    newQuantifiedVariable _ =+        pisFreshQVars . tTyp . Lens._Wrapped <<+= 1 <&> Name . ('t':) . show++instance MonadQuantify RConstraints Name PureInferB where+    newQuantifiedVariable _ =+        pisFreshQVars . tRow . Lens._Wrapped <<+= 1 <&> Name . ('r':) . show++instance Unify PureInferB Typ where+    binding = bindingDict (pisBindings . tTyp)++instance Unify PureInferB Row where+    binding = bindingDict (pisBindings . tRow)+    structureMismatch = rStructureMismatch++instance HasScheme Types PureInferB Typ+instance HasScheme Types PureInferB Row++newtype STInferB s a =+    STInferB+    (ReaderT (InferScope (STUVar s), STNameGen s)+        (ExceptT (TypeError # Pure) (ST s)) a)+    deriving newtype+    ( Functor, Applicative, Monad, MonadST+    , MonadError (TypeError # Pure)+    , MonadReader (InferScope (STUVar s), STNameGen s)+    )++Lens.makePrisms ''STInferB++execSTInferB :: STInferB s a -> ST s (Either (TypeError # Pure) a)+execSTInferB act =+    do+        qvarGen <- Types <$> (newSTRef 0 <&> Const) <*> (newSTRef 0 <&> Const)+        runReaderT (act ^. _STInferB) (emptyInferScope, qvarGen) & runExceptT++type instance UVarOf (STInferB s) = STUVar s++instance MonadNominals Name Typ (STInferB s) where+    getNominalDecl name = Lens.view (Lens._1 . nominals) <&> (^?! Lens.ix name)++instance HasScope (STInferB s) ScopeTypes where+    getScope = Lens.view (Lens._1 . varSchemes)++instance LocalScopeType Name (STUVar s # Typ) (STInferB s) where+    localScopeType h v = local (Lens._1 . varSchemes . _ScopeTypes . Lens.at h ?~ MkHFlip (GMono v))++instance LocalScopeType Name (GTerm (STUVar s) # Typ) (STInferB s) where+    localScopeType h v = local (Lens._1 . varSchemes . _ScopeTypes . Lens.at h ?~ MkHFlip v)++instance MonadScopeLevel (STInferB s) where+    localLevel = local (Lens._1 . scopeLevel . _ScopeLevel +~ 1)++instance UnifyGen (STInferB s) Typ where+    scopeConstraints _ = Lens.view (Lens._1 . scopeLevel)++instance UnifyGen (STInferB s) Row where+    scopeConstraints _ = Lens.view (Lens._1 . scopeLevel) <&> RowConstraints mempty++instance MonadQuantify ScopeLevel Name (STInferB s) where+    newQuantifiedVariable _ = newStQuantified (Lens._2 . tTyp) <&> Name . ('t':) . show++instance MonadQuantify RConstraints Name (STInferB s) where+    newQuantifiedVariable _ = newStQuantified (Lens._2 . tRow) <&> Name . ('r':) . show++instance Unify (STInferB s) Typ where+    binding = stBinding++instance Unify (STInferB s) Row where+    binding = stBinding+    structureMismatch = rStructureMismatch++instance HasScheme Types (STInferB s) Typ+instance HasScheme Types (STInferB s) Row
+ test/LangC.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings, FlexibleContexts, UndecidableInstances, FlexibleInstances #-}++module LangC where++import TypeLang (Name)++import Control.Lens.Operators+import Data.List.NonEmpty (NonEmpty(..), cons)+import Hyper+import Hyper.Class.Morph (morphMapped1)+import Hyper.Recurse ((##>>), wrap)+import Hyper.Type.AST.App (App(..))+import Hyper.Type.AST.Lam (Lam(..), lamOut)+import Hyper.Type.AST.Let (Let(..))+import Hyper.Type.AST.Row (RowExtend(..))+import Hyper.Type.AST.Var (Var(..))++import Prelude++-- Demonstrating de-sugaring of a sugar-language to a core language:+-- * Let-expressions are replaced with redexes+-- * Cases and if-else expressions are replaced with applied lambda-cases++data CoreForms l h+    = CLit Int+    | CApp (App l h)+    | CVar (Var Name l h)+    | CLam (Lam Name l h)+    | CRecEmpty+    | CRecExtend (RowExtend Name l l h)+    | CGetField (h :# l) Name+    | CLamCaseEmpty+    | CLamCaseExtend (RowExtend Name l l h)+    | CInject (h :# l) Name+    deriving Generic++newtype LangCore h = LangCore (CoreForms LangCore h)++data IfThen h = IfThen (h :# LangSugar) (h :# LangSugar)+data Case h = Case Name Name (h :# LangSugar)++data LangSugar h+    = SBase (CoreForms LangSugar h)+    | SLet (Let Name LangSugar h)+    | SCase (h :# LangSugar) [Case h]+    | SIfElse (NonEmpty (IfThen h)) (h :# LangSugar)++makeHMorph ''CoreForms+makeHTraversableAndBases ''CoreForms+makeHTraversableAndBases ''LangCore+makeHTraversableAndBases ''IfThen+makeHTraversableAndBases ''Case+makeHTraversableAndBases ''LangSugar++instance RNodes LangSugar+instance RTraversable LangSugar+instance c LangSugar => Recursively c LangSugar++desugar :: Pure # LangSugar -> Pure # LangCore+desugar (Pure body) =+    case body of+    SBase x ->+        -- Note how we desugar all of the base forms without any boilerplate!+        x & morphMapped1 %~ desugar & core+    SLet x ->+        cLam v i `cApp` e+        where+            Let v i e = x & morphMapped1 %~ desugar+    SCase e h ->+        foldr step cAbsurd h `cApp` desugar e+        where+            step (Case c v b) = cAddLamCase c (v `cLam` desugar b)+    SIfElse g e ->+        foldr step (desugar e) g+        where+            step (IfThen c t) r =+                cAddLamCase "True" (cLam "_" (desugar t))+                (cAddLamCase "False" (cLam "_" r) cAbsurd)+                `cApp` desugar c+    where+        core = Pure . LangCore+        cApp x = core . CApp . App x+        cLam v = core . CLam . Lam v+        cAbsurd = core CLamCaseEmpty+        cAddLamCase c h = core . CLamCaseExtend . RowExtend c h++-- Lift core language into the surface language+coreToSugar :: Pure # LangCore -> Pure # LangSugar+coreToSugar (Pure (LangCore x)) = x & morphMapped1 %~ coreToSugar & SBase & Pure++-- Convert top-level expression to sugared form when possible+sugarizeTop :: LangSugar # Pure -> LangSugar # Pure+sugarizeTop top@(SBase (CApp (App (Pure (SBase func)) arg))) =+    case func of+    CLam (Lam v b) -> Let v arg b & SLet+    CLamCaseExtend (RowExtend c0 (Pure (SBase (CLam h0))) r0) ->+        go ((c0, h0) :| []) r0+        where+            go cases (Pure (SBase CLamCaseEmpty)) =+                case cases of+                ("True", t) :| [("False", f)] | checkIf t f -> makeIf t f+                ("False", f) :| [("True", t)] | checkIf t f -> makeIf t f+                _ ->+                    cases ^.. traverse+                    <&> (\(n, Lam v b) -> Case n v b)+                    & SCase arg+                where+                    makeIf t f =+                        case f ^. lamOut of+                        Pure (SIfElse is e) -> SIfElse (cons i is) e+                        _ -> SIfElse (pure i) (f ^. lamOut)+                        where+                            i = IfThen arg (t ^. lamOut)+            go cases (Pure (SBase (CLamCaseExtend (RowExtend c (Pure (SBase (CLam h))) r)))) =+                go (cons (c, h) cases) r+            go _ _ = top+            checkIf t f = checkIfBranch t && checkIfBranch f+            checkIfBranch (Lam v b) = not (usesVar v b)+    _ -> top+sugarizeTop x = x++usesVar :: Name -> Pure # LangSugar -> Bool+usesVar v (Pure (SBase (CVar (Var x)))) = v == x+usesVar v (Pure x) = any (usesVar v) (x ^.. hfolded1)++sugarize :: Pure # LangSugar -> Pure # LangSugar+sugarize = wrap (Proxy @((~) LangSugar) ##>> Pure . sugarizeTop)
+ test/LangD.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell, UndecidableInstances #-}+module LangD where++import Hyper++newtype A i k = A (B i k)+newtype B i k = B (i (k :# A i))++makeHTraversableApplyAndBases ''A+makeHTraversableApplyAndBases ''B++newtype C (k :: AHyperType) = C (C k)+-- The following doesn't work:+-- makeHNodes ''C
+ test/ReadMeExamples.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, UndecidableInstances, FlexibleInstances, DerivingVia, PolyKinds, DeriveAnyClass #-}++module ReadMeExamples where++import Data.Text+import GHC.Generics (Generic1)+import Generics.Constraints (makeDerivings)+import Hyper+import Hyper.Class.ZipMatch+import Hyper.Diff+import Hyper.Type.AST.App+import Hyper.Type.AST.Var+import Hyper.Type.AST.TypedLam++import Prelude++data Expr h+    = EVar Text+    | EApp (h :# Expr) (h :# Expr)+    | ELam Text (h :# Typ) (h :# Expr)+    deriving Generic++data Typ h+    = TInt+    | TFunc (h :# Typ) (h :# Typ)+    deriving Generic++makeDerivings [''Eq, ''Ord, ''Show] [''Expr, ''Typ]+makeHTraversableAndBases ''Expr+makeHTraversableAndBases ''Typ+makeZipMatch ''Expr+makeZipMatch ''Typ++instance RNodes Expr+instance RNodes Typ+instance (c Expr, c Typ) => Recursively c Expr+instance c Typ => Recursively c Typ+instance RTraversable Expr+instance RTraversable Typ++data RExpr h+    = RVar (Var Text RExpr h)+    | RApp (App RExpr h)+    | RLam (TypedLam Text Typ RExpr h)+    deriving+    ( Generic, Generic1+    , HNodes, HFunctor, HFoldable, HTraversable, ZipMatch+    , RNodes, Recursively c, RTraversable+    )++makeHasHPlain [''Expr, ''Typ, ''RExpr]++verboseExpr :: Pure # Expr+verboseExpr = Pure (ELam "x" (Pure TInt) (Pure (EVar "x")))++exprA, exprB :: HPlain RExpr+exprA = RLamP "x" TIntP (RVarP "x")+exprB = RLamP "x" (TFuncP TIntP TIntP) (RVarP "x")++d :: DiffP # RExpr+d = diffP exprA exprB++formatDiff :: (Show a, Show b) => w -> a -> b -> String+formatDiff _ x y = "- " <> show x <> "\n+ " <> show y <> "\n"
+ test/Spec.hs view
@@ -0,0 +1,463 @@+{-# LANGUAGE FlexibleContexts, BlockArguments, OverloadedStrings #-}++import qualified Control.Lens as Lens+import           Control.Lens.Operators+import           Control.Monad.Except+import           Control.Monad.RWS+import           Control.Monad.ST (runST)+import           Data.Functor.Identity (Identity(..))+import qualified Data.Map as Map+import qualified Data.Set as Set+import           Hyper+import           Hyper.Infer+import           Hyper.Unify+import           Hyper.Unify.Generalize (generalize)+import           Hyper.Unify.QuantifiedVar (HasQuantifiedVar(..))+import           Hyper.Recurse (wrap)+import           Hyper.Type.AST.NamelessScope (EmptyScope)+import           Hyper.Type.AST.Nominal (NominalDecl(..), loadNominalDecl)+import           Hyper.Type.AST.Scheme+import           Hyper.Type.AST.Scheme.AlphaEq (alphaEq)+import           LangA+import           LangB+import           System.Exit (exitFailure)+import qualified Text.PrettyPrint as Pretty+import           Text.PrettyPrint.HughesPJClass (Pretty(..))+import           TypeLang++import           Prelude++lamXYx5 :: HPlain (LangA EmptyScope)+lamXYx5 =+    -- λx y. x 5+    ALamP (ALamP (AVarP (Just Nothing) `AAppP` ALitP 5))++infinite :: HPlain (LangA EmptyScope)+infinite =+    -- λx. x x+    ALamP (AVarP Nothing `AAppP` AVarP Nothing)++skolem :: HPlain (LangA EmptyScope)+skolem =+    -- λx. (x : ∀a. a)+    ALamP+    ( ATypeSigP+        (AVarP Nothing)+        (Types (QVars (mempty & Lens.at "a" ?~ mempty)) (QVars mempty))+        (TVarP "a")+    )++validForAll :: HPlain (LangA EmptyScope)+validForAll =+    -- (λx. x) : ∀a. a -> a+    ATypeSigP+    (ALamP (AVarP Nothing))+    (Types (QVars (mempty & Lens.at "a" ?~ mempty)) (QVars mempty))+    (TVarP "a" `TFunP` TVarP "a")++nomLam :: HPlain (LangA EmptyScope)+nomLam =+    -- λx. (x : Map[key: Int, value: Int])+    ALamP+    ( ATypeSigP+        (AVarP Nothing)+        (Types (QVars mempty) (QVars mempty))+        (TNomP "Map"+            (Types+                (QVarInstances+                    (mempty+                        & Lens.at "key" ?~ Pure TInt+                        & Lens.at "value" ?~ Pure TInt+                    )+                )+                (QVarInstances mempty)+            )+        )+    )++letGen0 :: HPlain LangB+letGen0 =+    BLetP "id" (BLamP "x" "x") $+    "id" `BAppP` "id" `BAppP` BLitP 5++letGen1 :: HPlain LangB+letGen1 =+    BLetP "five" (BLitP 5) $+    BLetP "f" (BLamP "x" ("x" `BAppP` "five" `BAppP` "five"))+    "f"++letGen2 :: HPlain LangB+letGen2 =+    BLetP "f" (BLamP "x" (BGetFieldP "x" "a")) $+    BLamP "x" ("f" `BAppP` ("f" `BAppP` "x"))++genInf :: HPlain LangB+genInf =+    BLetP "f" (BLamP "x" ("x" `BAppP` "x"))+    "f"++shouldNotGen :: HPlain LangB+shouldNotGen =+    BLamP "x"+    ( BLetP "y" "x"+        "y"+    )++simpleRec :: HPlain LangB+simpleRec =+    BRecExtendP "a" (BLitP 5)+    BRecEmptyP++extendLit :: HPlain LangB+extendLit =+    BRecExtendP "a" (BLitP 5) $+    BLitP 7++extendDup :: HPlain LangB+extendDup =+    BRecExtendP "a" (BLitP 7) $+    BRecExtendP "a" (BLitP 5)+    BRecEmptyP++extendGood :: HPlain LangB+extendGood =+    BRecExtendP "b" (BLitP 7) $+    BRecExtendP "a" (BLitP 5)+    BRecEmptyP++getAField :: HPlain LangB+getAField = BLamP "x" (BGetFieldP "x" "a")++vecApp :: HPlain LangB+vecApp =+    BLamP "x"+    ( BLamP "y"+        ( BToNomP "Vec" $+            BRecExtendP "x" "x" $+            BRecExtendP "y" "y"+            BRecEmptyP+        )+    )++usePhantom :: HPlain LangB+usePhantom = BToNomP "PhantomInt" (BLitP 5)++unifyRows :: HPlain LangB+unifyRows =+    BLamP "f" ("f" `BAppP` r0 `BAppP` ("f" `BAppP` r1 `BAppP` BLitP 12))+    where+        r0 =+            BRecExtendP "a" (BLitP 5) $+            BRecExtendP "b" (BLitP 7)+            BRecEmptyP+        r1 =+            BRecExtendP "b" (BLitP 5) $+            BRecExtendP "a" (BLitP 7)+            BRecEmptyP++openRows :: HPlain LangB+openRows =+    BLamP "x" $+    BLamP "y" $+    BLamP "f" $+    "f" `BAppP` r0 `BAppP` ("f" `BAppP` r1 `BAppP` BLitP 12)+    where+        r0 =+            BRecExtendP "a" (BLitP 5) $+            BRecExtendP "b" (BLitP 7) $+            BVarP "x"+        r1 =+            BRecExtendP "c" (BLitP 5) $+            BRecExtendP "a" (BLitP 7) $+            BVarP "y"++return5 :: HPlain LangB+return5 = "return" `BAppP` BLitP 5++returnOk :: HPlain LangB+returnOk = BToNomP "LocalMut" return5++nomSkolem0 :: HPlain LangB+nomSkolem0 = BLamP "x" (BToNomP "LocalMut" "x")++nomSkolem1 :: HPlain LangB+nomSkolem1 = nomSkolem0 `BAppP` return5++inferExpr ::+    forall m t.+    ( HasInferredType t+    , Infer m t+    , HasScheme Types m (TypeOf t)+    , RTraversable t+    , RTraversableInferOf t+    ) =>+    Pure # t ->+    m (Pure # Scheme Types (TypeOf t))+inferExpr x =+    do+        inferRes <- infer (wrap (const (Ann (Const ()))) x)+        result <-+            inferRes ^# hAnn . Lens._2 . _InferResult . inferredType (Proxy @t)+            & generalize+            >>= saveScheme+        result <$+            htraverse_+            ( Proxy @(Infer m) #*# Proxy @RTraversableInferOf #*#+                \w (Const () :*: InferResult i) ->+                withDict (inferContext (Proxy @m) w) $+                htraverse_ (Proxy @(UnifyGen m) #> void . applyBindings) i+            ) (_HFlip # inferRes)++vecNominalDecl :: Pure # NominalDecl Typ+vecNominalDecl =+    _Pure # NominalDecl+    { _nParams =+        Types+        { _tRow = mempty+        , _tTyp = mempty & Lens.at "elem" ?~ mempty+        }+    , _nScheme =+        Scheme+        { _sForAlls = Types mempty mempty+        , _sTyp =+            ( REmptyP+                & RExtendP "x" (TVarP "elem")+                & RExtendP "y" (TVarP "elem")+                & TRecP+            ) ^. hPlain+        }+    }++phantomIntNominalDecl :: Pure # NominalDecl Typ+phantomIntNominalDecl =+    _Pure # NominalDecl+    { _nParams =+        Types+        { _tRow = mempty+        , _tTyp = mempty & Lens.at "phantom" ?~ mempty+        }+    , _nScheme =+        Scheme+        { _sForAlls = Types mempty mempty+        , _sTyp = _Pure # TInt+        }+    }++mutType :: HPlain Typ+mutType =+    TNomP "Mut"+    Types+    { _tRow = mempty & Lens.at "effects" ?~ (RVar "effects" & Pure) & QVarInstances+    , _tTyp = mempty & Lens.at "value" ?~ (TVar "value" & Pure) & QVarInstances+    }++-- A nominal type with foralls:+-- "newtype LocalMut a = forall s. Mut s a"+localMutNominalDecl :: Pure # NominalDecl Typ+localMutNominalDecl =+    _Pure # NominalDecl+    { _nParams =+        Types+        { _tRow = mempty+        , _tTyp = mempty & Lens.at "value" ?~ mempty+        }+    , _nScheme =+        forAll (Const ()) (Identity "effects") (\_ _ -> mutType) ^. _Pure+    }++returnScheme :: Pure # Scheme Types Typ+returnScheme =+    forAll (Identity "value") (Identity "effects") $+    \(Identity val) _ -> TFunP val mutType++withEnv ::+    ( UnifyGen m Row, MonadReader env m+    , HasScheme Types m Typ+    ) =>+    Lens.LensLike' Identity env (InferScope (UVarOf m)) -> m a -> m a+withEnv l act =+    do+        vec <- loadNominalDecl vecNominalDecl+        phantom <- loadNominalDecl phantomIntNominalDecl+        localMut <- loadNominalDecl localMutNominalDecl+        let addNoms x =+                x+                & Lens.at "Vec" ?~ vec+                & Lens.at "PhantomInt" ?~ phantom+                & Lens.at "LocalMut" ?~ localMut+        ret <- loadScheme returnScheme+        let addEnv x =+                x+                & nominals %~ addNoms+                & varSchemes . _ScopeTypes . Lens.at "return" ?~ MkHFlip ret+        local (l %~ addEnv) act++prettyStyle :: Pretty a => a -> String+prettyStyle = Pretty.renderStyle (Pretty.Style Pretty.OneLineMode 0 0) . pPrint++prettyPrint :: Pretty a => a -> IO ()+prettyPrint = putStrLn . prettyStyle++testCommon ::+    (Pretty (lang # Pure), Pretty a, Eq a) =>+    Pure # lang ->+    String ->+    Either (TypeError # Pure) a ->+    Either (TypeError # Pure) a ->+    IO Bool+testCommon expr expect pureRes stRes =+    do+        putStrLn ""+        prettyPrint expr+        putStrLn "inferred to:"+        prettyPrint pureRes+        filter (not . fst) checks <&> snd & sequence_+        all fst checks & pure+    where+        checks =+            [ (expect == prettyStyle pureRes, putStrLn ("FAIL! Expected:\n" <> expect))+            , (pureRes == stRes, putStrLn "FAIL! Different result in ST:" *> prettyPrint stRes)+            ]++testA :: HPlain (LangA EmptyScope) -> String -> IO Bool+testA p expect =+    testCommon expr expect pureRes stRes+    where+        expr = p ^. hPlain+        pureRes = execPureInferA (inferExpr expr)+        stRes = runST (execSTInferA (inferExpr expr))++testB :: HPlain LangB -> String -> IO Bool+testB p expect =+    testCommon expr expect pureRes stRes+    where+        expr = p ^. hPlain+        pureRes = execPureInferB (withEnv id (inferExpr expr))+        stRes = runST (execSTInferB (withEnv Lens._1 (inferExpr expr)))++testAlphaEq :: Pure # Scheme Types Typ -> Pure # Scheme Types Typ -> Bool -> IO Bool+testAlphaEq x y expect =+    do+        putStrLn ""+        prettyPrint (x, y)+        putStrLn ("Alpha Eq: " <> show pureRes)+        when (pureRes /= expect) (putStrLn "WRONG!")+        putStrLn ("Alpha Eq: " <> show stRes)+        when (stRes /= expect) (putStrLn "WRONG!")+        pure (pureRes == expect && stRes == expect)+    where+        pureRes = Lens.has Lens._Right (execPureInferB (alphaEq x y))+        stRes = Lens.has Lens._Right (runST (execSTInferB (alphaEq x y)))++intsRecord :: [Name] -> Pure # Scheme Types Typ+intsRecord = uniType . TRecP . foldr (`RExtendP` TIntP) REmptyP++intToInt :: Pure # Scheme Types Typ+intToInt = TFunP TIntP TIntP & uniType++uniType :: HPlain Typ -> Pure # Scheme Types Typ+uniType typ =+    _Pure # Scheme+    { _sForAlls = Types (QVars mempty) (QVars mempty)+    , _sTyp = typ ^. hPlain+    }++forAll ::+    (Traversable t, Traversable u) =>+    t Name -> u Name ->+    (t (HPlain Typ) -> u (HPlain Row) -> HPlain Typ) ->+    Pure # Scheme Types Typ+forAll tvs rvs body =+    _Pure #+    Scheme (Types (foralls tvs) (foralls rvs))+    (body (tvs <&> TVarP) (rvs <&> RVarP) ^. hPlain)+    where+        foralls ::+            ( Foldable f+            , QVar typ ~ Name+            , Monoid (TypeConstraintsOf typ)+            ) =>+            f Name -> QVars # typ+        foralls xs =+            xs ^.. Lens.folded <&> (, mempty)+            & Map.fromList & QVars++forAll1 ::+    Name -> (HPlain Typ -> HPlain Typ) ->+    Pure # Scheme Types Typ+forAll1 t body =+    forAll (Identity t) (Const ()) $ \(Identity tv) _ -> body tv++forAll1r ::+    Name -> (HPlain Row -> HPlain Typ) ->+    Pure # Scheme Types Typ+forAll1r t body =+    forAll (Const ()) (Identity t) $ \_ (Identity tv) -> body tv++main :: IO ()+main =+    do+        numFails <-+            sequenceA tests+            <&> filter not <&> length+        putStrLn ""+        show numFails <> " tests failed out of " <> show (length tests) & putStrLn+        when (numFails > 0) exitFailure+    where+        tests =+            [ testA lamXYx5      "Right (∀t0(*). ∀t1(*). (Int -> t0) -> t1 -> t0)"+            , testA infinite     "Left (t0 occurs in itself, expands to: t0 -> t1)"+            , testA skolem       "Left (SkolemEscape: t0)"+            , testA validForAll  "Right (∀t0(*). t0 -> t0)"+            , testA nomLam       "Right (Map[key: Int, value: Int] -> Map[key: Int, value: Int])"+            , testB letGen0      "Right Int"+            , testB letGen1      "Right (∀t0(*). (Int -> Int -> t0) -> t0)"+            , testB letGen2      "Right (∀t0(*). ∀r0(∌ [a]). ∀r1(∌ [a]). (a : (a : t0 :*: r0) :*: r1) -> t0)"+            , testB genInf       "Left (t0 occurs in itself, expands to: t0 -> t1)"+            , testB shouldNotGen "Right (∀t0(*). t0 -> t0)"+            , testB simpleRec    "Right (a : Int :*: {})"+            , testB extendLit    "Left (Mismatch Int r0)"+            , testB extendDup    "Left (ConstraintsViolation (a : Int :*: {}) (∌ [a]))"+            , testB extendGood   "Right (b : Int :*: a : Int :*: {})"+            , testB unifyRows    "Right (((b : Int :*: a : Int :*: {}) -> Int -> Int) -> Int)"+            , testB openRows     "Right (∀r0(∌ [a, b, c]). (c : Int :*: r0) -> (b : Int :*: r0) -> ((c : Int :*: a : Int :*: b : Int :*: r0) -> Int -> Int) -> Int)"+            , testB getAField    "Right (∀t0(*). ∀r0(∌ [a]). (a : t0 :*: r0) -> t0)"+            , testB vecApp       "Right (∀t0(*). t0 -> t0 -> Vec[elem: t0])"+            , testB usePhantom   "Right (∀t0(*). PhantomInt[phantom: t0])"+            , testB return5      "Right (∀r0(*). Mut[value: Int, effects: r0])"+            , testB returnOk     "Right LocalMut[value: Int]"+            , testB nomSkolem0   "Left (SkolemEscape: r0)"+            , testB nomSkolem1   "Left (SkolemEscape: r0)"+            , testAlphaEq (uniType TIntP) (uniType TIntP) True+            , testAlphaEq (uniType TIntP) intToInt False+            , testAlphaEq intToInt intToInt True+            , testAlphaEq (intsRecord ["a", "b"]) (intsRecord ["b", "a"]) True+            , testAlphaEq (intsRecord ["a", "b"]) (intsRecord ["b"]) False+            , testAlphaEq (intsRecord ["a", "b", "c"]) (intsRecord ["c", "b", "a"]) True+            , testAlphaEq (intsRecord ["a", "b", "c"]) (intsRecord ["b", "c", "a"]) True+            , testAlphaEq (forAll1 "a" id) (forAll1 "b" id) True+            , testAlphaEq (forAll1 "a" id) (uniType TIntP) False+            , testAlphaEq (forAll1r "a" TRecP) (uniType TIntP) False+            , testAlphaEq (forAll1r "a" TRecP) (forAll1r "b" TRecP) True+            , testAlphaEq (mkOpenRec "a" "x" "y") (mkOpenRec "b" "y" "x") True+            , testAlphaEq (valH0 (TVarP "a")) (valH0 (TRecP REmptyP)) False+            ]+        mkOpenRec a x y =+            _Pure #+            Scheme+            (Types (QVars mempty)+                (QVars (Map.fromList [(a, RowConstraints (Set.fromList [x, y]) mempty)])))+            ( TRecP+                (RVarP a+                & RExtendP x TIntP+                & RExtendP y TIntP+                ) ^. hPlain+            )+        valH0 x =+            TFunP (TVarP "a") (TRecP (RExtendP "t" x (RVarP "c"))) ^. hPlain+            & Scheme+                ( Types+                    (QVars (mempty & Lens.at "a" ?~ mempty))+                    (QVars (mempty & Lens.at "c" ?~ RowConstraints (Set.fromList ["t"]) mempty))+                )+            & Pure
+ test/TypeLang.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE DerivingVia, UndecidableInstances #-}++module TypeLang where++import           Algebra.PartialOrd+import           Control.Applicative+import           Control.Lens (ALens')+import qualified Control.Lens as Lens+import           Control.Lens.Operators+import           Control.Monad.Except+import           Control.Monad.Reader (MonadReader)+import           Control.Monad.ST.Class (MonadST(..))+import           Data.STRef+import           Data.Set (Set)+import           Data.String (IsString)+import           Generic.Data+import           Generics.Constraints (Constraints, makeDerivings)+import           Hyper+import           Hyper.Class.Optic+import           Hyper.Infer+import           Hyper.Type.AST.FuncType+import           Hyper.Type.AST.NamelessScope+import           Hyper.Type.AST.Nominal+import           Hyper.Type.AST.Row+import           Hyper.Type.AST.Scheme+import           Hyper.Unify+import           Hyper.Unify.Binding+import           Hyper.Unify.QuantifiedVar+import           Text.PrettyPrint ((<+>))+import qualified Text.PrettyPrint as Pretty+import           Text.PrettyPrint.HughesPJClass (Pretty(..), maybeParens)++import           Prelude++newtype Name =+    Name String+    deriving stock Show+    deriving newtype (Eq, Ord, IsString)++data Typ h+    = TInt+    | TFun (FuncType Typ h)+    | TRec (h :# Row)+    | TVar Name+    | TNom (NominalInst Name Types h)+    deriving Generic++data Row h+    = REmpty+    | RExtend (RowExtend Name Typ Row h)+    | RVar Name+    deriving Generic++data RConstraints = RowConstraints+    { _rForbiddenFields :: Set Name+    , _rScope :: ScopeLevel+    } deriving stock (Eq, Ord, Show, Generic)+    deriving (Semigroup, Monoid) via Generically RConstraints++data Types h = Types+    { _tTyp :: h :# Typ+    , _tRow :: h :# Row+    } deriving Generic++data TypeError h+    = TypError (UnifyError Typ h)+    | RowError (UnifyError Row h)+    | QVarNotInScope Name+    deriving Generic++data PureInferState = PureInferState+    { _pisBindings :: Types # Binding+    , _pisFreshQVars :: Types # Const Int+    }++Lens.makePrisms ''Typ+Lens.makePrisms ''Row+Lens.makePrisms ''TypeError+Lens.makeLenses ''RConstraints+Lens.makeLenses ''Types+Lens.makeLenses ''PureInferState++makeZipMatch ''Types+makeZipMatch ''Typ+makeZipMatch ''Row+makeHContext ''Typ+makeHContext ''Row+makeHMorph ''Row+makeHTraversableApplyAndBases ''Types+makeHTraversableAndBases ''Typ+makeHTraversableAndBases ''Row++makeDerivings [''Eq, ''Ord, ''Show] [''Typ, ''Row, ''Types, ''TypeError]++makeHasHPlain [''Typ, ''Row]++type instance NomVarTypes Typ = Types++instance HasNominalInst Name Typ where nominalInst = _TNom++instance Pretty Name where+    pPrint (Name x) = Pretty.text x++instance Pretty RConstraints where+    pPrintPrec _ p (RowConstraints f _)+        | f == mempty = Pretty.text "*"+        | otherwise = Pretty.text "∌" <+> pPrint (f ^.. Lens.folded) & maybeParens (p > 10)++instance Constraints (Types h) Pretty => Pretty (Types h) where+    pPrintPrec lvl p (Types typ row) =+        pPrintPrec lvl p typ <+>+        pPrintPrec lvl p row++instance Constraints (TypeError h) Pretty => Pretty (TypeError h) where+    pPrintPrec lvl p (TypError x) = pPrintPrec lvl p x+    pPrintPrec lvl p (RowError x) = pPrintPrec lvl p x+    pPrintPrec _ _ (QVarNotInScope x) =+        Pretty.text "quantified type variable not in scope" <+> pPrint x++instance Constraints (Typ h) Pretty => Pretty (Typ h) where+    pPrintPrec _ _ TInt = Pretty.text "Int"+    pPrintPrec lvl p (TFun x) = pPrintPrec lvl p x+    pPrintPrec lvl p (TRec x) = pPrintPrec lvl p x+    pPrintPrec _ _ (TVar s) = pPrint s+    pPrintPrec _ _ (TNom n) = pPrint n++instance Constraints (Types h) Pretty => Pretty (Row h) where+    pPrintPrec _ _ REmpty = Pretty.text "{}"+    pPrintPrec lvl p (RExtend (RowExtend h v r)) =+        pPrintPrec lvl 20 h <+>+        Pretty.text ":" <+>+        pPrintPrec lvl 2 v <+>+        Pretty.text ":*:" <+>+        pPrintPrec lvl 1 r+        & maybeParens (p > 1)+    pPrintPrec _ _ (RVar s) = pPrint s++instance HNodeLens Types Typ where hNodeLens = tTyp+instance HNodeLens Types Row where hNodeLens = tRow++instance PartialOrd RConstraints where+    RowConstraints f0 s0 `leq` RowConstraints f1 s1 = f0 `leq` f1 && s0 `leq` s1++instance TypeConstraints RConstraints where+    generalizeConstraints = rScope .~ mempty+    toScopeConstraints = rForbiddenFields .~ mempty++instance RowConstraints RConstraints where+    type RowConstraintsKey RConstraints = Name+    forbidden = rForbiddenFields++instance HasTypeConstraints Typ where+    type instance TypeConstraintsOf Typ = ScopeLevel+    verifyConstraints _ TInt = Just TInt+    verifyConstraints _ (TVar v) = TVar v & Just+    verifyConstraints c (TFun f) = f & hmapped1 %~ WithConstraint c & TFun & Just+    verifyConstraints c (TRec r) = WithConstraint (RowConstraints mempty c) r & TRec & Just+    verifyConstraints c (TNom (NominalInst n (Types t r))) =+        Types+        (t & _QVarInstances . traverse %~ WithConstraint c)+        (r & _QVarInstances . traverse %~ WithConstraint (RowConstraints mempty c))+        & NominalInst n & TNom & Just++instance HasTypeConstraints Row where+    type instance TypeConstraintsOf Row = RConstraints+    verifyConstraints _ REmpty = Just REmpty+    verifyConstraints _ (RVar x) = RVar x & Just+    verifyConstraints c (RExtend x) =+        verifyRowExtendConstraints (^. rScope) c x <&> RExtend++emptyPureInferState :: PureInferState+emptyPureInferState =+    PureInferState+    { _pisBindings = Types emptyBinding emptyBinding+    , _pisFreshQVars = Types (Const 0) (Const 0)+    }++type STNameGen s = Types # Const (STRef s Int)++instance (c Typ, c Row) => Recursively c Typ+instance (c Typ, c Row) => Recursively c Row+instance RNodes Typ+instance RNodes Row+instance RTraversable Typ+instance RTraversable Row+instance RTraversableInferOf Typ+instance RTraversableInferOf Row++instance HasQuantifiedVar Typ where+    type QVar Typ = Name+    quantifiedVar = _TVar++instance HasQuantifiedVar Row where+    type QVar Row = Name+    quantifiedVar = _RVar++instance HSubset Typ Typ (FuncType Typ) (FuncType Typ) where hSubset = _TFun+instance HSubset TypeError TypeError (UnifyError Typ) (UnifyError Typ) where hSubset = _TypError+instance HSubset TypeError TypeError (UnifyError Row) (UnifyError Row) where hSubset = _RowError++instance HasScopeTypes v Typ a => HasScopeTypes v Typ (a, x) where+    scopeTypes = Lens._1 . scopeTypes++type instance InferOf Typ = ANode Typ+type instance InferOf Row = ANode Row+instance HasInferredValue Typ where inferredValue = _ANode+instance HasInferredValue Row where inferredValue = _ANode++instance+    (Monad m, MonadInstantiate m Typ, MonadInstantiate m Row) =>+    Infer m Typ where+    inferBody = inferType++instance+    (Monad m, MonadInstantiate m Typ, MonadInstantiate m Row) =>+    Infer m Row where+    inferBody = inferType++rStructureMismatch ::+    (UnifyGen m Typ, UnifyGen m Row) =>+    (forall c. Unify m c => UVarOf m # c -> UVarOf m # c -> m (UVarOf m # c)) ->+    Row # UVarOf m -> Row # UVarOf m -> m ()+rStructureMismatch match (RExtend r0) (RExtend r1) =+    rowExtendStructureMismatch match _RExtend r0 r1+rStructureMismatch _ x y = unifyError (Mismatch x y)++readModifySTRef :: MonadST m => STRef (World m) a -> (a -> a) -> m a+readModifySTRef ref func =+    do+        old <- readSTRef ref+        old <$ (writeSTRef ref $! func old)+        & liftST++newStQuantified ::+    (MonadReader env m, MonadST m, Enum a) =>+    ALens' env (Const (STRef (World m) a) (ast :: AHyperType)) ->+    m a+newStQuantified l =+    Lens.view (Lens.cloneLens l . Lens._Wrapped)+    >>= (`readModifySTRef` succ)